diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,35 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.11.0.0] - 2024-12-29 + +### Added +- Added `deriveGADT` for deriving all relevant instances for GADTs. + ([#267](https://github.com/lsrcz/grisette/pull/267)) +- Added `EvalModeConvertible` for a unified constraint for the evaluation modes + that can be converted to each other with `ToCon` and `ToSym`. + ([#267](https://github.com/lsrcz/grisette/pull/267)) + +### Changed +- [Breaking] We no longer support direct `toCon` from a union to a single value + or `toSym` from a single value to a union. These should now be done through + `mrgToSym`, `toUnionSym`, and `unionToCon`. + ([#267](https://github.com/lsrcz/grisette/pull/267)) +- [Breaking] Changed the `EvalMode` tag for `Con` to `C` and `Sym` to `S`. + ([#267](https://github.com/lsrcz/grisette/pull/267)) + +### Fixed +- Fixed some missing constraints for unified interfaces. + ([#267](https://github.com/lsrcz/grisette/pull/267)) +- Fixed badly staged types in the lifting of terms. + ([#267](https://github.com/lsrcz/grisette/pull/267)) +- Fixed the `Read` instance for bit-vectors on GHC 9.12. + ([#267](https://github.com/lsrcz/grisette/pull/267)) + +### Removed +- Removed old template-haskell-based derivation mechanism. + ([#267](https://github.com/lsrcz/grisette/pull/267)) + ## [0.10.0.0] - 2024-12-11 ### Added @@ -520,7 +549,7 @@ - Initial release for Grisette. -[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.10.0.0...HEAD +[0.11.0.0]: https://github.com/lsrcz/grisette/compare/v0.10.0.0...HEAD [0.10.0.0]: https://github.com/lsrcz/grisette/compare/v0.9.0.0...v0.10.0.0 [0.9.0.0]: https://github.com/lsrcz/grisette/compare/v0.8.0.0...v0.9.0.0 [0.8.0.0]: https://github.com/lsrcz/grisette/compare/v0.7.0.0...v0.8.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ ```cabal library ... - build-depends: grisette >= 0.10 < 0.11 + build-depends: grisette >= 0.11 < 0.12 ``` #### Using stack @@ -59,14 +59,14 @@ ```yaml extra-deps: - - grisette-0.10.0.0 + - grisette-0.11.0.0 ``` and in your `package.yaml` file: ```yaml dependencies: - - grisette >= 0.10 < 0.11 + - grisette >= 0.11 < 0.12 ``` #### Quick start template with `stack new` @@ -168,33 +168,36 @@ data Expr a where IntVal :: SymInteger -> IntExpr BoolVal :: SymBool -> BoolExpr - Add :: UIntExpr -> UIntExpr -> IntExpr - Mul :: UIntExpr -> UIntExpr -> IntExpr - BAnd :: UBoolExpr -> UBoolExpr -> BoolExpr - BOr :: UBoolExpr -> UBoolExpr -> BoolExpr + Add :: IntUExpr -> IntUExpr -> IntExpr + Mul :: IntUExpr -> IntUExpr -> IntExpr + BAnd :: BoolUExpr -> BoolUExpr -> BoolExpr + BOr :: BoolUExpr -> BoolUExpr -> BoolExpr Eq :: (BasicSymPrim a) => UExpr a -> UExpr a -> BoolExpr type IntExpr = Expr SymInteger type BoolExpr = Expr SymBool type UExpr a = Union (Expr a) -type UIntExpr = UExpr SymInteger -type UBoolExpr = UExpr SymBool +type IntUExpr = UExpr SymInteger +type BoolUExpr = UExpr SymBool ``` To make this GADT works well with Grisette, we need to derive some instances and get some smart constructors: -- `deriveGADTAll` derives all the instances related to Grisette, and +- `deriveGADT` provides instances for data types that are frequently used with + or provided by Grisette. See the + [documentation](https://hackage.haskell.org/package/grisette/docs/Grisette-TH.html) + for the details on what instances are provided. - `makeSmartCtor` generates smart constructors for the GADT. ```haskell deriving instance Show (Expr a) -deriveGADTAll ''Expr +deriveGADT [''Expr] basicClasses0 makeSmartCtor ''Expr -> intVal 1 :: UIntExpr -- smart constructor for IntVal in Unions +> intVal 1 :: IntUExpr -- smart constructor for IntVal in Unions {IntVal 1} --- Add takes two UIntExprs, use the smart constructors +-- Add takes two IntUExprs, use the smart constructors > Add (intVal "a") (intVal 1) Add {IntVal a} {IntVal 1} ``` @@ -207,7 +210,7 @@ ```haskell add2 = add (intVal "a") (intVal 2) mul2 = mul (intVal "a") (intVal 2) -> mrgIf "choice" add2 mul2 :: UIntExpr +> mrgIf "choice" add2 mul2 :: IntUExpr {If choice {Add {IntVal a} {IntVal 2}} {Mul {IntVal a} {IntVal 2}}} ``` @@ -248,11 +251,11 @@ different values. ```haskell -lhs = Add (intVal "a") (intVal "b") -rhs = Add (intVal "b") (intVal "a") -rhs2 = Add (intVal "a") (intVal "a") +aPlusB = Add (intVal "a") (intVal "b") +bPlusA = Add (intVal "b") (intVal "a") +aPlusA = Add (intVal "a") (intVal "a") -> solve z3 $ eval lhs ./= eval rhs +> solve z3 $ eval aPlusB ./= eval bPlusA Left Unsat ``` @@ -262,7 +265,7 @@ $a+a=0$. ``` haskell -> solve z3 $ eval lhs ./= eval rhs2 +> solve z3 $ eval aPlusB ./= eval aPlusA Right (Model {a -> 0 :: Integer, b -> 1 :: Integer}) ``` 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.10.0.0 +version: 0.11.0.0 synopsis: Symbolic evaluation as a library description: Grisette is a reusable symbolic evaluation library for Haskell. By translating programs into constraints, Grisette can help the development of @@ -38,8 +38,9 @@ , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.6 - , GHC == 9.8.3 + , GHC == 9.8.4 , GHC == 9.10.1 + , GHC == 9.12.1 extra-source-files: CHANGELOG.md README.md @@ -157,19 +158,66 @@ Grisette.Internal.TH.Ctor.Common Grisette.Internal.TH.Ctor.SmartConstructor Grisette.Internal.TH.Ctor.UnifiedConstructor - Grisette.Internal.TH.DeriveBuiltin - Grisette.Internal.TH.DeriveInstanceProvider - Grisette.Internal.TH.DerivePredefined - Grisette.Internal.TH.DeriveTypeParamHandler - Grisette.Internal.TH.DeriveUnifiedInterface - Grisette.Internal.TH.DeriveWithHandlers + Grisette.Internal.TH.GADT.BinaryOpCommon Grisette.Internal.TH.GADT.Common + Grisette.Internal.TH.GADT.ConvertOpCommon + Grisette.Internal.TH.GADT.DeriveAllSyms + Grisette.Internal.TH.GADT.DeriveEq Grisette.Internal.TH.GADT.DeriveEvalSym Grisette.Internal.TH.GADT.DeriveExtractSym Grisette.Internal.TH.GADT.DeriveGADT + Grisette.Internal.TH.GADT.DeriveHashable Grisette.Internal.TH.GADT.DeriveMergeable + Grisette.Internal.TH.GADT.DeriveNFData + Grisette.Internal.TH.GADT.DeriveOrd + Grisette.Internal.TH.GADT.DerivePPrint + Grisette.Internal.TH.GADT.DeriveSerial + Grisette.Internal.TH.GADT.DeriveShow + Grisette.Internal.TH.GADT.DeriveSimpleMergeable + Grisette.Internal.TH.GADT.DeriveSubstSym + Grisette.Internal.TH.GADT.DeriveSymEq + Grisette.Internal.TH.GADT.DeriveSymOrd + Grisette.Internal.TH.GADT.DeriveToCon + Grisette.Internal.TH.GADT.DeriveToSym + Grisette.Internal.TH.GADT.DeriveUnifiedSimpleMergeable + Grisette.Internal.TH.GADT.DeriveUnifiedSymEq + Grisette.Internal.TH.GADT.DeriveUnifiedSymOrd + Grisette.Internal.TH.GADT.ShowPPrintCommon Grisette.Internal.TH.GADT.UnaryOpCommon + Grisette.Internal.TH.GADT.UnifiedOpCommon Grisette.Internal.TH.Util + Grisette.Internal.Unified.BaseConstraint + Grisette.Internal.Unified.BaseMonad + Grisette.Internal.Unified.BVBVConversion + Grisette.Internal.Unified.BVFPConversion + Grisette.Internal.Unified.Class.UnifiedFiniteBits + Grisette.Internal.Unified.Class.UnifiedFromIntegral + Grisette.Internal.Unified.Class.UnifiedITEOp + Grisette.Internal.Unified.Class.UnifiedRep + Grisette.Internal.Unified.Class.UnifiedSafeBitCast + Grisette.Internal.Unified.Class.UnifiedSafeDiv + Grisette.Internal.Unified.Class.UnifiedSafeFdiv + Grisette.Internal.Unified.Class.UnifiedSafeFromFP + Grisette.Internal.Unified.Class.UnifiedSafeLinearArith + Grisette.Internal.Unified.Class.UnifiedSafeSymRotate + Grisette.Internal.Unified.Class.UnifiedSafeSymShift + Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + Grisette.Internal.Unified.Class.UnifiedSolvable + Grisette.Internal.Unified.Class.UnifiedSymEq + Grisette.Internal.Unified.Class.UnifiedSymOrd + Grisette.Internal.Unified.EvalMode + Grisette.Internal.Unified.EvalModeTag + Grisette.Internal.Unified.FPFPConversion + Grisette.Internal.Unified.Theories + Grisette.Internal.Unified.UnifiedAlgReal + Grisette.Internal.Unified.UnifiedBool + Grisette.Internal.Unified.UnifiedBV + Grisette.Internal.Unified.UnifiedData + Grisette.Internal.Unified.UnifiedFP + Grisette.Internal.Unified.UnifiedFun + Grisette.Internal.Unified.UnifiedInteger + Grisette.Internal.Unified.UnifiedPrim + Grisette.Internal.Unified.Util Grisette.Internal.Utils.Derive Grisette.Internal.Utils.Parameterized Grisette.Lib.Base @@ -196,45 +244,64 @@ Grisette.SymPrim Grisette.TH Grisette.Unified - Grisette.Unified.Internal.BaseConstraint - Grisette.Unified.Internal.BaseMonad - Grisette.Unified.Internal.BVBVConversion - Grisette.Unified.Internal.BVFPConversion - Grisette.Unified.Internal.Class.UnifiedFiniteBits - Grisette.Unified.Internal.Class.UnifiedFromIntegral - Grisette.Unified.Internal.Class.UnifiedITEOp - Grisette.Unified.Internal.Class.UnifiedRep - Grisette.Unified.Internal.Class.UnifiedSafeBitCast - Grisette.Unified.Internal.Class.UnifiedSafeDiv - Grisette.Unified.Internal.Class.UnifiedSafeFdiv - Grisette.Unified.Internal.Class.UnifiedSafeFromFP - Grisette.Unified.Internal.Class.UnifiedSafeLinearArith - Grisette.Unified.Internal.Class.UnifiedSafeSymRotate - Grisette.Unified.Internal.Class.UnifiedSafeSymShift - Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - Grisette.Unified.Internal.Class.UnifiedSolvable - Grisette.Unified.Internal.Class.UnifiedSymEq - Grisette.Unified.Internal.Class.UnifiedSymOrd - Grisette.Unified.Internal.EvalMode - Grisette.Unified.Internal.EvalModeTag - Grisette.Unified.Internal.FPFPConversion - Grisette.Unified.Internal.Theories - Grisette.Unified.Internal.UnifiedAlgReal - Grisette.Unified.Internal.UnifiedBool - Grisette.Unified.Internal.UnifiedBV - Grisette.Unified.Internal.UnifiedData - Grisette.Unified.Internal.UnifiedFP - Grisette.Unified.Internal.UnifiedFun - Grisette.Unified.Internal.UnifiedInteger - Grisette.Unified.Internal.UnifiedPrim - Grisette.Unified.Internal.Util Grisette.Unified.Lib.Control.Applicative Grisette.Unified.Lib.Control.Monad Grisette.Unified.Lib.Data.Foldable Grisette.Unified.Lib.Data.Functor Grisette.Utils other-modules: - Paths_grisette + Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym + Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint + Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon + Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv + Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym + Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym + Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + Grisette.Internal.Internal.Decl.Core.Data.Class.Solver + Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym + Grisette.Internal.Internal.Decl.Core.Data.UnionBase + Grisette.Internal.Internal.Decl.Core.Control.Monad.Union + Grisette.Internal.Internal.Decl.SymPrim.AllSyms + Grisette.Internal.Internal.Decl.Unified.UnifiedBV + Grisette.Internal.Internal.Decl.Unified.UnifiedBool + Grisette.Internal.Internal.Decl.Unified.BVFPConversion + Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq + Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd + Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable + Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp + Grisette.Internal.Internal.Decl.Unified.UnifiedFP + Grisette.Internal.Internal.Decl.Unified.EvalMode + Grisette.Internal.Internal.Decl.Unified.FPFPConversion + Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym + Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint + Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon + Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv + Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym + Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym + Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq + Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge + Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd + Grisette.Internal.Internal.Impl.Core.Data.Class.Solver + Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable + Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable + Grisette.Internal.Internal.Impl.Core.Data.Class.EvalSym + Grisette.Internal.Internal.Impl.Core.Data.UnionBase + Grisette.Internal.Internal.Impl.Core.Control.Monad.Union + Grisette.Internal.Internal.Impl.SymPrim.AllSyms + Grisette.Internal.Internal.Impl.Unified.UnifiedBV + Grisette.Internal.Internal.Impl.Unified.UnifiedBool + Grisette.Internal.Internal.Impl.Unified.BVFPConversion + Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq + Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd + Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable + Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp + Grisette.Internal.Internal.Impl.Unified.UnifiedFP + Grisette.Internal.Internal.Impl.Unified.EvalMode + Grisette.Internal.Internal.Impl.Unified.FPFPConversion hs-source-dirs: src ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags @@ -253,7 +320,7 @@ , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , generic-deriving >=1.14.1 && <1.15 - , hashable >=1.2.3 && <1.6 + , hashable >=1.2.5 && <1.6 , libBF >=0.6.3 && <0.7 , loch-th >=0.2.2 && <0.3 , mtl >=2.2.2 && <2.4 @@ -261,7 +328,7 @@ , prettyprinter >=1.5.0 && <1.8 , sbv >=8.17 && <12 , stm ==2.5.* - , template-haskell >=2.16 && <2.23 + , template-haskell >=2.16 && <2.24 , text >=1.2.4.1 && <2.2 , th-abstraction >=0.4 && <0.8 , th-compat >=0.1.2 && <0.2 @@ -297,10 +364,10 @@ , cereal-text >=0.1.0.2 && <0.2 , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 - , doctest >=0.18.2 && <0.23 + , doctest >=0.18.2 && <0.24 , generic-deriving >=1.14.1 && <1.15 , grisette - , hashable >=1.2.3 && <1.6 + , hashable >=1.2.5 && <1.6 , libBF >=0.6.3 && <0.7 , loch-th >=0.2.2 && <0.3 , mtl >=2.2.2 && <2.4 @@ -308,7 +375,7 @@ , prettyprinter >=1.5.0 && <1.8 , sbv >=8.17 && <12 , stm ==2.5.* - , template-haskell >=2.16 && <2.23 + , template-haskell >=2.16 && <2.24 , text >=1.2.4.1 && <2.2 , th-abstraction >=0.4 && <0.8 , th-compat >=0.1.2 && <0.2 @@ -356,7 +423,9 @@ Grisette.Core.Data.Class.ToSymTests Grisette.Core.Data.Class.TryMergeTests Grisette.Core.Data.UnionBaseTests + Grisette.Core.TH.DerivationData Grisette.Core.TH.DerivationTest + Grisette.Core.TH.PartialEvalMode Grisette.Lib.Control.ApplicativeTest Grisette.Lib.Control.Monad.ExceptTests Grisette.Lib.Control.Monad.State.ClassTests @@ -415,7 +484,7 @@ , deepseq >=1.4.4 && <1.6 , generic-deriving >=1.14.1 && <1.15 , grisette - , hashable >=1.2.3 && <1.6 + , hashable >=1.2.5 && <1.6 , libBF >=0.6.3 && <0.7 , loch-th >=0.2.2 && <0.3 , mtl >=2.2.2 && <2.4 @@ -423,7 +492,7 @@ , prettyprinter >=1.5.0 && <1.8 , sbv >=8.17 && <12 , stm ==2.5.* - , template-haskell >=2.16 && <2.23 + , template-haskell >=2.16 && <2.24 , test-framework >=0.8.2 && <0.9 , test-framework-hunit >=0.3.0.2 && <0.4 , test-framework-quickcheck2 >=0.3.0.5 && <0.4 diff --git a/src/Grisette/Core.hs b/src/Grisette/Core.hs --- a/src/Grisette/Core.hs +++ b/src/Grisette/Core.hs @@ -556,16 +556,13 @@ -- deriving (Mergeable) via (Default X) -- :} -- - -- Grisette also provide 'Grisette.deriveAll' template haskell procedure to + -- Grisette also provide 'Grisette.deriveGADT' template haskell procedure to -- derive all the instances for the classes that are relevant. This include - -- 'GHC.Generics.Generic', 'Show', 'Mergeable', etc. If you only want to - -- derive some of them, you can also use 'Grisette.deriveAllExcept' or - -- 'Grisette.derive'. + -- 'Show', 'Mergeable', 'Mergeable1', etc. -- -- >>> :{ -- data X = X SymInteger Integer - -- deriveAllExcept ''X [''Ord] - -- -- Ord is excluded because it is a symbolic type + -- deriveGADT [''X] [''Show, ''Mergeable] -- :} -- -- Having the 'Mergeable' instance allows you to use the 'Union' type to @@ -596,7 +593,7 @@ -- >>> import Control.Monad.Except -- >>> :{ -- data Error = Fail - -- deriveAll ''Error + -- deriveGADT [''Error] allClasses0 -- :} -- -- >>> mrgIf "a" (throwError Fail) (return "x") :: ExceptT Error Union SymInteger @@ -1381,12 +1378,15 @@ GToCon (..), genericToCon, genericLiftToCon, + unionToCon, -- *** 'ToSym' ToSymArgs (..), GToSym (..), genericToSym, genericLiftToSym, + mrgToSym, + toUnionSym, -- *** 'EvalSym' EvalSymArgs (..), @@ -1645,6 +1645,7 @@ onUnion3, onUnion4, simpleMerge, + unionToCon, (.#), pattern If, pattern Single, @@ -1801,6 +1802,8 @@ TryMerge (..), mrgSingle, mrgSingleWithStrategy, + mrgToSym, + toUnionSym, tryMerge, ) import Grisette.Internal.Core.Data.MemoUtils diff --git a/src/Grisette/Internal/Core/Control/Monad/Union.hs b/src/Grisette/Internal/Core/Control/Monad/Union.hs --- a/src/Grisette/Internal/Core/Control/Monad/Union.hs +++ b/src/Grisette/Internal/Core/Control/Monad/Union.hs @@ -1,21 +1,4 @@ -{-# 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 -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Control.Monad.Union @@ -40,652 +23,5 @@ ) where -import Control.Applicative (Alternative ((<|>))) -import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) -import qualified Data.Binary as Binary -import Data.Bytes.Serial (Serial (deserialize, serialize)) -import Data.Functor.Classes - ( Eq1 (liftEq), - Show1 (liftShowsPrec), - showsPrec1, - ) -import qualified Data.HashMap.Lazy as HML -import Data.Hashable (Hashable (hashWithSalt)) -import qualified Data.Serialize as Cereal -import Data.String (IsString (fromString)) -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) -import Grisette.Internal.Core.Data.Class.EvalSym - ( EvalSym (evalSym), - EvalSym1 (liftEvalSym), - evalSym1, - ) -import Grisette.Internal.Core.Data.Class.ExtractSym - ( ExtractSym (extractSymMaybe), - ExtractSym1 (liftExtractSymMaybe), - extractSymMaybe1, - ) -import Grisette.Internal.Core.Data.Class.Function (Function ((#))) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.Core.Data.Class.LogicalOp - ( LogicalOp (false, symImplies, symNot, symXor, true, (.&&), (.||)), - ) -import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (SimpleStrategy), - rootStrategy1, - ) -import Grisette.Internal.Core.Data.Class.PPrint - ( PPrint (pformatPrec), - PPrint1 (liftPFormatPrec), - groupedEnclose, - pformatPrec1, - ) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( PlainUnion (ifView, singleView), - simpleMerge, - ) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), - mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable - ( Solvable (con, conView, sym), - pattern Con, - ) -import Grisette.Internal.Core.Data.Class.Solver - ( UnionWithExcept (extractUnionExcept), - ) -import Grisette.Internal.Core.Data.Class.SubstSym - ( SubstSym (substSym), - SubstSym1 (liftSubstSym), - substSym1, - ) -import Grisette.Internal.Core.Data.Class.SymEq - ( SymEq ((.==)), - SymEq1 (liftSymEq), - symEq1, - ) -import Grisette.Internal.Core.Data.Class.ToCon - ( ToCon (toCon), - ToCon1 (liftToCon), - toCon1, - ) -import Grisette.Internal.Core.Data.Class.ToSym - ( ToSym (toSym), - ToSym1 (liftToSym), - toSym1, - ) -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge (tryMergeWithStrategy), - mrgSingle, - mrgSingleWithStrategy, - tryMerge, - ) -import Grisette.Internal.Core.Data.UnionBase - ( UnionBase (UnionIf, UnionSingle), - ifWithLeftMost, - ) -import Grisette.Internal.SymPrim.AllSyms - ( AllSyms (allSymsS), - AllSyms1 (liftAllSymsS), - allSymsS1, - ) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.GeneralFun - ( type (-->), - ) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedNonFuncPrim, - SupportedPrim, - ) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN, - SymWordN, - ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) -import Language.Haskell.TH.Syntax.Compat (unTypeSplice) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | 'Union' is the 'UnionBase' container (hidden) enhanced with --- 'MergingStrategy' --- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). --- --- The 'UnionBase' models the underlying semantics evaluation semantics for --- unsolvable types with the nested if-then-else tree semantics, and can be --- viewed as the following structure: --- --- > data UnionBase a --- > = UnionSingle a --- > | UnionIf bool (Union a) (Union a) --- --- The 'UnionSingle' constructor is for a single value with the path condition --- @true@, and the 'UnionIf' constructor is the if operator in an if-then-else --- tree. --- For clarity, when printing a 'Union' value, we will omit the 'UnionSingle' --- constructor. The following two representations has the same semantics. --- --- > If c1 (If c11 v11 (If c12 v12 v13)) --- > (If c2 v2 --- > v3) --- --- \[ --- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. --- \] --- --- To reduce the size of the if-then-else tree to reduce the number of paths to --- execute, Grisette would merge the branches in a 'UnionBase' container and --- maintain a representation invariant for them. To perform this merging --- procedure, Grisette relies on a type class called 'Mergeable' and the --- merging strategy defined by it. --- --- 'UnionBase' is a monad, so we can easily write code with the do-notation and --- monadic combinators. However, the standard monadic operators cannot --- resolve any extra constraints, including the 'Mergeable' constraint (see --- [The constrained-monad --- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) --- by Sculthorpe et al.). --- This prevents the standard do-notations to merge the results automatically, --- and would result in bad performance or very verbose code. --- --- To reduce this boilerplate, Grisette provide another monad, 'Union' that --- would try to cache the merging strategy. --- The 'Union' has two data constructors (hidden intentionally), 'UAny' and --- 'UMrg'. The 'UAny' data constructor (printed as @<@@...@@>@) wraps an --- arbitrary (probably unmerged) 'UnionBase'. It is constructed when no --- 'Mergeable' knowledge is available (for example, when constructed with --- Haskell\'s 'return'). The 'UMrg' data constructor (printed as @{...}@) wraps --- a merged 'UnionBase' along with the 'Mergeable' constraint. This constraint --- can be propagated to the contexts without 'Mergeable' knowledge, and helps --- the system to merge the resulting 'UnionBase'. --- --- __/Examples:/__ --- --- 'return' cannot resolve the 'Mergeable' constraint. --- --- >>> return 1 :: Union Integer --- <1> --- --- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. --- --- >>> import Grisette.Lib.Base --- >>> mrgReturn 1 :: Union Integer --- {1} --- --- 'mrgIfPropagatedStrategy' does not try to 'Mergeable' constraint. --- --- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (return 1) (return 2)) :: Union Integer --- --- --- But 'mrgIfPropagatedStrategy' is able to merge the result if some of the --- branches are merged and have a cached merging strategy: --- --- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (mrgReturn 1) (return 2)) :: Union Integer --- {If (|| a b) 1 2} --- --- The '>>=' operator uses 'mrgIfPropagatedStrategy' internally. When the final --- statement in a do-block merges the values, the system can then merge the --- final result. --- --- >>> :{ --- do --- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) --- mrgSingle $ x + 1 :: Union Integer --- :} --- {If (|| a b) 2 3} --- --- Calling a function that merges a result at the last line of a do-notation --- will also merge the whole block. If you stick to these @mrg*@ combinators and --- all the functions will merge the results, the whole program can be --- symbolically evaluated efficiently. --- --- >>> f x y = mrgIf "c" x y :: Union Integer --- >>> :{ --- do --- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) --- f x (x + 1) --- :} --- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} --- --- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ --- variants of other combinators. You should stick to these combinators to --- ensure efficient merging by Grisette. -data Union a where - -- | 'Union' with no 'Mergeable' knowledge. - UAny :: - -- | Original 'UnionBase'. - UnionBase a -> - Union a - -- | 'Union' with 'Mergeable' knowledge. - UMrg :: - -- | Cached merging strategy. - MergingStrategy a -> - -- | Merged 'UnionBase' - UnionBase a -> - Union a - -instance (Mergeable a, Serial a) => Serial (Union a) where - serialize = serialize . unionBase - deserialize = UMrg rootStrategy <$> deserialize - -instance (Mergeable a, Serial a) => Cereal.Serialize (Union a) where - put = serialize - get = deserialize - -instance (Mergeable a, Serial a) => Binary.Binary (Union a) where - put = serialize - get = deserialize - --- | Get the (possibly empty) cached merging strategy. -unionMergingStrategy :: Union a -> Maybe (MergingStrategy a) -unionMergingStrategy (UMrg s _) = Just s -unionMergingStrategy _ = Nothing - -instance (NFData a) => NFData (Union a) where - rnf = rnf1 - -instance NFData1 Union where - liftRnf _a (UAny m) = liftRnf _a m - liftRnf _a (UMrg _ m) = liftRnf _a m - -instance (Lift a) => Lift (Union a) where - liftTyped (UAny v) = [||UAny v||] - liftTyped (UMrg _ v) = [||UAny v||] - lift = unTypeSplice . liftTyped - -instance (Show a) => (Show (Union a)) where - showsPrec = showsPrec1 - -liftShowsPrecUnion :: - forall a. - (Int -> a -> ShowS) -> - ([a] -> ShowS) -> - Int -> - UnionBase a -> - ShowS -liftShowsPrecUnion sp _ i (UnionSingle a) = sp i a -liftShowsPrecUnion sp sl i (UnionIf _ _ cond t f) = - showParen (i > 10) $ - showString "If" - . showChar ' ' - . showsPrec 11 cond - . showChar ' ' - . sp1 11 t - . showChar ' ' - . sp1 11 f - where - sp1 = liftShowsPrecUnion sp sl - -wrapBracket :: Char -> Char -> ShowS -> ShowS -wrapBracket l r p = showChar l . p . showChar r - -instance Show1 Union where - liftShowsPrec sp sl _ (UAny a) = - wrapBracket '<' '>' - . liftShowsPrecUnion sp sl 0 - $ a - liftShowsPrec sp sl _ (UMrg _ a) = - wrapBracket '{' '}' - . liftShowsPrecUnion sp sl 0 - $ a - -instance (PPrint a) => PPrint (Union a) where - pformatPrec = pformatPrec1 - -instance PPrint1 Union where - liftPFormatPrec fa fl _ = \case - (UAny a) -> groupedEnclose "<" ">" $ liftPFormatPrec fa fl 0 a - (UMrg _ a) -> groupedEnclose "{" "}" $ liftPFormatPrec fa fl 0 a - --- | Extract the underlying Union. May be unmerged. -unionBase :: Union a -> UnionBase a -unionBase (UAny a) = a -unionBase (UMrg _ a) = a -{-# INLINE unionBase #-} - --- | Check if a 'Union' is already merged. -isMerged :: Union a -> Bool -isMerged UAny {} = False -isMerged UMrg {} = True -{-# INLINE isMerged #-} - -instance PlainUnion Union where - singleView = singleView . unionBase - {-# INLINE singleView #-} - ifView (UAny u) = case ifView u of - Just (c, t, f) -> Just (c, UAny t, UAny f) - Nothing -> Nothing - ifView (UMrg m u) = case ifView u of - Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) - Nothing -> Nothing - {-# INLINE ifView #-} - -instance Functor Union where - fmap f fa = fa >>= return . f - {-# INLINE fmap #-} - -instance Applicative Union where - pure = UAny . pure - {-# INLINE pure #-} - f <*> a = f >>= (\xf -> a >>= (return . xf)) - {-# INLINE (<*>) #-} - -bindUnionBase :: UnionBase a -> (a -> Union b) -> Union b -bindUnionBase (UnionSingle a') f' = f' a' -bindUnionBase (UnionIf _ _ cond ifTrue ifFalse) f' = - mrgIfPropagatedStrategy - cond - (bindUnionBase ifTrue f') - (bindUnionBase ifFalse f') -{-# INLINE bindUnionBase #-} - -instance Monad Union where - a >>= f = bindUnionBase (unionBase a) f - {-# INLINE (>>=) #-} - --- | Lift a unary operation to 'Union'. -unionUnaryOp :: (a -> a) -> Union a -> Union a -unionUnaryOp f a = do - a1 <- a - maybe return mrgSingleWithStrategy (unionMergingStrategy a) $ f a1 -{-# INLINE unionUnaryOp #-} - --- | Lift a binary operation to 'Union'. -unionBinOp :: - (a -> a -> a) -> - Union a -> - Union a -> - Union a -unionBinOp f a b = do - a1 <- a - b1 <- b - maybe - return - mrgSingleWithStrategy - (unionMergingStrategy a <|> unionMergingStrategy b) - $ f a1 b1 -{-# INLINE unionBinOp #-} - -instance (Mergeable a) => Mergeable (Union a) where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable a) => SimpleMergeable (Union a) where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance Mergeable1 Union where - liftRootStrategy m = SimpleStrategy $ mrgIfWithStrategy m - {-# INLINE liftRootStrategy #-} - -instance SimpleMergeable1 Union where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance TryMerge Union where - tryMergeWithStrategy _ m@(UMrg _ _) = m - tryMergeWithStrategy s (UAny u) = UMrg s $ tryMergeWithStrategy s u - {-# INLINE tryMergeWithStrategy #-} - -instance SymBranching Union where - mrgIfWithStrategy s (Con c) l r = - if c then tryMergeWithStrategy s l else tryMergeWithStrategy s r - mrgIfWithStrategy s cond l r = - UMrg s $ - mrgIfWithStrategy - s - cond - (unionBase l) - (unionBase r) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (UAny t) (UAny f) = - UAny $ ifWithLeftMost False cond t f - mrgIfPropagatedStrategy cond t@(UMrg m _) f = mrgIfWithStrategy m cond t f - mrgIfPropagatedStrategy cond t f@(UMrg m _) = mrgIfWithStrategy m cond t f - {-# INLINE mrgIfPropagatedStrategy #-} - -instance (SymEq a) => SymEq (Union a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance SymEq1 Union where - liftSymEq f x y = simpleMerge $ f <$> x <*> y - {-# INLINE liftSymEq #-} - --- | Lift the 'Union' to any Applicative 'SymBranching'. -liftUnion :: - forall u a. (Mergeable a, SymBranching u, Applicative u) => Union a -> u a -liftUnion u = go (unionBase u) - where - go :: UnionBase a -> u a - go (UnionSingle v) = mrgSingle v - go (UnionIf _ _ c t f) = mrgIf c (go t) (go f) - --- | Alias for `liftUnion`, but for monads. -liftToMonadUnion :: (Mergeable a, MonadUnion u) => Union a -> u a -liftToMonadUnion = liftUnion - -instance {-# INCOHERENT #-} (ToSym a b, Mergeable b) => ToSym a (Union b) where - toSym = mrgSingle . toSym - -instance (ToSym a b) => ToSym (Union a) (Union b) where - toSym = toSym1 - -instance ToSym1 Union Union where - liftToSym f = tryMerge . fmap f - -instance ToSym (Union Bool) SymBool where - toSym = simpleMerge . fmap con - -instance ToSym (Union Integer) SymInteger where - toSym = simpleMerge . fmap con - -instance (KnownNat n, 1 <= n) => ToSym (Union (IntN n)) (SymIntN n) where - toSym = simpleMerge . fmap con - -instance (KnownNat n, 1 <= n) => ToSym (Union (WordN n)) (SymWordN n) where - toSym = simpleMerge . fmap con - -instance - ( SupportedPrim ((=->) ca cb), - SupportedNonFuncPrim ca, - LinkedRep ca sa, - LinkedRep cb sb - ) => - ToSym (Union ((=->) ca cb)) ((=~>) sa sb) - where - toSym = simpleMerge . fmap con - -instance - ( SupportedPrim ((-->) ca cb), - SupportedNonFuncPrim ca, - LinkedRep ca sa, - LinkedRep cb sb - ) => - ToSym (Union ((-->) ca cb)) ((-~>) sa sb) - where - toSym = simpleMerge . fmap con - -instance {-# INCOHERENT #-} (ToCon a b, Mergeable a) => ToCon (Union a) b where - toCon v = go $ unionBase $ tryMerge v - where - go (UnionSingle x) = toCon x - go _ = Nothing - -instance (ToCon a b) => ToCon (Union a) (Union b) where - toCon = toCon1 - -instance ToCon1 Union Union where - liftToCon f v = go $ unionBase v - where - go (UnionSingle x) = case f x of - Nothing -> Nothing - Just v -> Just $ return v - go (UnionIf _ _ c t f) = do - t' <- go t - f' <- go f - return $ mrgIfPropagatedStrategy c t' f' - -instance (EvalSym a) => EvalSym (Union a) where - evalSym = evalSym1 - -instance EvalSym1 Union where - liftEvalSym f fillDefault model x = go $ unionBase x - where - go (UnionSingle v) = single $ f fillDefault model v - go (UnionIf _ _ cond t f) = - unionIf (evalSym fillDefault model cond) (go t) (go f) - strategy = unionMergingStrategy x - single = maybe return mrgSingleWithStrategy strategy - unionIf = maybe mrgIfPropagatedStrategy mrgIfWithStrategy strategy - -instance (SubstSym a) => SubstSym (Union a) where - substSym = substSym1 - -instance SubstSym1 Union where - liftSubstSym f sym val x = go $ unionBase x - where - go (UnionSingle v) = single $ f sym val v - go (UnionIf _ _ cond t f) = - unionIf - (substSym sym val cond) - (go t) - (go f) - strategy = unionMergingStrategy x - single = maybe return mrgSingleWithStrategy strategy - unionIf = maybe mrgIfPropagatedStrategy mrgIfWithStrategy strategy - -instance (ExtractSym a) => ExtractSym (Union a) where - extractSymMaybe = extractSymMaybe1 - -instance ExtractSym1 Union where - liftExtractSymMaybe e v = go $ unionBase v - where - go (UnionSingle x) = e x - go (UnionIf _ _ cond t f) = extractSymMaybe cond <> go t <> go f - -instance (Hashable a) => Hashable (Union a) where - s `hashWithSalt` (UAny u) = s `hashWithSalt` (0 :: Int) `hashWithSalt` u - s `hashWithSalt` (UMrg _ u) = s `hashWithSalt` (1 :: Int) `hashWithSalt` u - -instance (Eq a) => Eq (Union a) where - UAny l == UAny r = l == r - UMrg _ l == UMrg _ r = l == r - _ == _ = False - -instance Eq1 Union where - liftEq e l r = liftEq e (unionBase l) (unionBase r) - -instance (Num a, Mergeable a) => Num (Union a) where - fromInteger = mrgSingle . fromInteger - negate = unionUnaryOp negate - (+) = unionBinOp (+) - (*) = unionBinOp (*) - (-) = unionBinOp (-) - abs = unionUnaryOp abs - signum = unionUnaryOp signum - -instance (ITEOp a, Mergeable a) => ITEOp (Union a) where - symIte = mrgIf - -instance (LogicalOp a, Mergeable a) => LogicalOp (Union a) where - true = mrgSingle true - false = mrgSingle false - (.||) = unionBinOp (.||) - (.&&) = unionBinOp (.&&) - symNot = unionUnaryOp symNot - symXor = unionBinOp symXor - symImplies = unionBinOp symImplies - -instance (Solvable c t, Mergeable t) => Solvable c (Union t) where - con = mrgSingle . con - {-# INLINE con #-} - sym = mrgSingle . sym - {-# INLINE sym #-} - conView v = do - c <- singleView $ tryMerge v - conView c - {-# INLINE conView #-} - -instance - (Function f arg ret, Mergeable f, Mergeable ret) => - Function (Union f) arg (Union ret) - where - f # a = do - f1 <- f - mrgSingle $ f1 # a - -instance (IsString a, Mergeable a) => IsString (Union a) where - fromString = mrgSingle . fromString - --- AllSyms -instance (AllSyms a) => AllSyms (Union a) where - allSymsS = allSymsS1 - -instance AllSyms1 Union where - liftAllSymsS f = liftAllSymsS f . unionBase - --- Concrete Key HashMaps - --- | Tag for concrete types. --- Useful for specifying the merge strategy for some parametrized types where we should have different --- merge strategy for symbolic and concrete ones. -class (Eq t, Ord t, Hashable t) => IsConcrete t - -instance IsConcrete Bool - -instance IsConcrete Integer - -instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (Union (Maybe t))) where - rootStrategy = SimpleStrategy mrgIte - -instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (Union (Maybe t))) where - mrgIte cond l r = - HML.unionWith (mrgIf cond) ul ur - where - ul = - foldr - ( \k m -> case HML.lookup k m of - Nothing -> HML.insert k (mrgSingle Nothing) m - _ -> m - ) - l - (HML.keys r) - ur = - foldr - ( \k m -> case HML.lookup k m of - Nothing -> HML.insert k (mrgSingle Nothing) m - _ -> m - ) - r - (HML.keys l) - -instance UnionWithExcept (Union (Either e v)) Union e v where - extractUnionExcept = id - --- | The size of a union is defined as the number of branches. --- For example, --- --- >>> unionSize (return True) --- 1 --- >>> unionSize (mrgIf "a" (return 1) (return 2) :: Union Integer) --- 2 --- >>> unionSize (choose [1..7] "a" :: Union Integer) --- 7 -unionSize :: Union a -> Int -unionSize = unionSize' . unionBase - where - unionSize' (UnionSingle _) = 1 - unionSize' (UnionIf _ _ _ l r) = unionSize' l + unionSize' r +import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union +import Grisette.Internal.Internal.Impl.Core.Control.Monad.Union diff --git a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs --- a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs +++ b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} @@ -68,11 +69,16 @@ ) where +#if MIN_VERSION_base(4,20,0) +import Data.List (partition) +#else +import Data.List (foldl', partition) +#endif + import Control.DeepSeq (NFData) import qualified Data.Binary as Binary import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable) -import Data.List (foldl', partition) import qualified Data.Serialize as Cereal import GHC.Generics (Generic) import Generics.Deriving (Default (Default)) diff --git a/src/Grisette/Internal/Core/Data/Class/EvalSym.hs b/src/Grisette/Internal/Core/Data/Class/EvalSym.hs --- a/src/Grisette/Internal/Core/Data/Class/EvalSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/EvalSym.hs @@ -1,19 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.EvalSym @@ -42,614 +27,5 @@ ) where -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import qualified Data.HashSet as HS -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Maybe (fromJust) -import Data.Monoid (Alt, Ap) -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator, (%)) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Default1 (Default1, unDefault1), - Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Generics.Deriving.Instances () -import qualified Generics.Deriving.Monoid as Monoid -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Class.ToCon - ( ToCon (toCon), - ToCon1, - ToCon2, - toCon1, - toCon2, - ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) -import Grisette.Internal.SymPrim.Prim.Model (Model, evalTerm) -import Grisette.Internal.SymPrim.Prim.Term - ( SymRep (SymType), - someTypedSymbol, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Data.Proxy - --- | Evaluating symbolic values with some model. This would substitute the --- symbols (symbolic constants) with the values in the model. --- --- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model --- >>> evalSym False model ([ssym "a", ssym "b"] :: [SymInteger]) --- [1,b] --- --- If we set the first argument true, the missing symbols will be filled in --- with some default values: --- --- >>> evalSym True model ([ssym "a", ssym "b"] :: [SymInteger]) --- [1,0] --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving EvalSym via (Default X) -class EvalSym a where - -- | Evaluate a symbolic value with some model, possibly fill in values for - -- the missing symbols. - evalSym :: Bool -> Model -> a -> a - --- | Evaluate a symbolic value with some model, fill in values for the missing --- symbols, and convert the result to a concrete value. --- --- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model --- >>> evalSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] --- [1,0] -evalSymToCon :: (ToCon a b, EvalSym a) => Model -> a -> b -evalSymToCon model a = fromJust $ toCon $ evalSym True model a - --- | Lifting of 'EvalSym' to unary type constructors. -class (forall a. (EvalSym a) => EvalSym (f a)) => EvalSym1 f where - -- | Lift the 'evalSym' function to unary type constructors. - liftEvalSym :: (Bool -> Model -> a -> a) -> (Bool -> Model -> f a -> f a) - --- | Lifting the standard 'evalSym' to unary type constructors. -evalSym1 :: (EvalSym1 f, EvalSym a) => Bool -> Model -> f a -> f a -evalSym1 = liftEvalSym evalSym -{-# INLINE evalSym1 #-} - --- | Evaluate and convert to concrete values with lifted standard 'evalSym' for --- unary type constructors. See 'evalSymToCon'. -evalSymToCon1 :: - (EvalSym1 f, EvalSym a, ToCon1 f g, ToCon a b) => - Model -> - f a -> - g b -evalSymToCon1 model a = fromJust $ toCon1 $ evalSym1 True model a -{-# INLINE evalSymToCon1 #-} - --- | Lifting of 'EvalSym1' to binary type constructors. -class (forall a. (EvalSym a) => EvalSym1 (f a)) => EvalSym2 f where - -- | Lift the 'evalSym' function to binary type constructors. - liftEvalSym2 :: - (Bool -> Model -> a -> a) -> - (Bool -> Model -> b -> b) -> - (Bool -> Model -> f a b -> f a b) - --- | Lifting the standard 'evalSym' to binary type constructors. -evalSym2 :: - (EvalSym2 f, EvalSym a, EvalSym b) => - Bool -> - Model -> - f a b -> - f a b -evalSym2 = liftEvalSym2 evalSym evalSym -{-# INLINE evalSym2 #-} - --- | Evaluate and convert to concrete values with lifted standard 'evalSym' for --- binary type constructors. See 'evalSymToCon'. -evalSymToCon2 :: - ( EvalSym2 f, - EvalSym a, - EvalSym c, - ToCon2 f g, - ToCon a b, - ToCon c d - ) => - Model -> - f a c -> - g b d -evalSymToCon2 model a = fromJust $ toCon2 $ evalSym2 True model a -{-# INLINE evalSymToCon2 #-} - --- Derivations - --- | The arguments to the generic 'evalSym' function. -data family EvalSymArgs arity a :: Type - -data instance EvalSymArgs Arity0 _ = EvalSymArgs0 - -newtype instance EvalSymArgs Arity1 a - = EvalSymArgs1 (Bool -> Model -> a -> a) - --- | The class of types that can be generically evaluated. -class GEvalSym arity f where - gevalSym :: EvalSymArgs arity a -> Bool -> Model -> f a -> f a - -instance GEvalSym arity V1 where - gevalSym _ _ _ = id - {-# INLINE gevalSym #-} - -instance GEvalSym arity U1 where - gevalSym _ _ _ = id - {-# INLINE gevalSym #-} - -instance - (GEvalSym arity a, GEvalSym arity b) => - GEvalSym arity (a :*: b) - where - gevalSym args fillDefault model (a :*: b) = - gevalSym args fillDefault model a - :*: gevalSym args fillDefault model b - {-# INLINE gevalSym #-} - -instance - (GEvalSym arity a, GEvalSym arity b) => - GEvalSym arity (a :+: b) - where - gevalSym args fillDefault model (L1 l) = - L1 $ gevalSym args fillDefault model l - gevalSym args fillDefault model (R1 r) = - R1 $ gevalSym args fillDefault model r - {-# INLINE gevalSym #-} - -instance (GEvalSym arity a) => GEvalSym arity (M1 i c a) where - gevalSym args fillDefault model (M1 x) = - M1 $ gevalSym args fillDefault model x - {-# INLINE gevalSym #-} - -instance (EvalSym a) => GEvalSym arity (K1 i a) where - gevalSym _ fillDefault model (K1 x) = K1 $ evalSym fillDefault model x - {-# INLINE gevalSym #-} - -instance GEvalSym Arity1 Par1 where - gevalSym (EvalSymArgs1 f) fillDefault model (Par1 x) = - Par1 $ f fillDefault model x - {-# INLINE gevalSym #-} - -instance (EvalSym1 a) => GEvalSym Arity1 (Rec1 a) where - gevalSym (EvalSymArgs1 f) fillDefault model (Rec1 x) = - Rec1 $ liftEvalSym f fillDefault model x - {-# INLINE gevalSym #-} - -instance - (EvalSym1 f, GEvalSym Arity1 g) => - GEvalSym Arity1 (f :.: g) - where - gevalSym targs fillDefault model (Comp1 x) = - Comp1 $ liftEvalSym (gevalSym targs) fillDefault model x - {-# INLINE gevalSym #-} - --- | Generic 'evalSym' function. -genericEvalSym :: - (Generic a, GEvalSym Arity0 (Rep a)) => Bool -> Model -> a -> a -genericEvalSym fillDefault model = - to . gevalSym EvalSymArgs0 fillDefault model . from -{-# INLINE genericEvalSym #-} - --- | Generic 'liftEvalSym' function. -genericLiftEvalSym :: - (Generic1 f, GEvalSym Arity1 (Rep1 f)) => - (Bool -> Model -> a -> a) -> - Bool -> - Model -> - f a -> - f a -genericLiftEvalSym f fillDefault model = - to1 . gevalSym (EvalSymArgs1 f) fillDefault model . from1 -{-# INLINE genericLiftEvalSym #-} - -instance - (Generic a, GEvalSym Arity0 (Rep a)) => - EvalSym (Default a) - where - evalSym fillDefault model = - Default . genericEvalSym fillDefault model . unDefault - {-# INLINE evalSym #-} - -instance - (Generic1 f, GEvalSym Arity1 (Rep1 f), EvalSym a) => - EvalSym (Default1 f a) - where - evalSym = evalSym1 - {-# INLINE evalSym #-} - -instance - (Generic1 f, GEvalSym Arity1 (Rep1 f)) => - EvalSym1 (Default1 f) - where - liftEvalSym f fillDefault model = - Default1 . genericLiftEvalSym f fillDefault model . unDefault1 - {-# INLINE liftEvalSym #-} - -#define CONCRETE_EVALUATESYM(type) \ -instance EvalSym type where \ - evalSym _ _ = id - -#define CONCRETE_EVALUATESYM_BV(type) \ -instance (KnownNat n, 1 <= n) => EvalSym (type n) where \ - evalSym _ _ = id - -#if 1 -CONCRETE_EVALUATESYM(Bool) -CONCRETE_EVALUATESYM(Integer) -CONCRETE_EVALUATESYM(Char) -CONCRETE_EVALUATESYM(Int) -CONCRETE_EVALUATESYM(Int8) -CONCRETE_EVALUATESYM(Int16) -CONCRETE_EVALUATESYM(Int32) -CONCRETE_EVALUATESYM(Int64) -CONCRETE_EVALUATESYM(Word) -CONCRETE_EVALUATESYM(Word8) -CONCRETE_EVALUATESYM(Word16) -CONCRETE_EVALUATESYM(Word32) -CONCRETE_EVALUATESYM(Word64) -CONCRETE_EVALUATESYM(Float) -CONCRETE_EVALUATESYM(Double) -CONCRETE_EVALUATESYM(B.ByteString) -CONCRETE_EVALUATESYM(T.Text) -CONCRETE_EVALUATESYM(FPRoundingMode) -CONCRETE_EVALUATESYM(Monoid.All) -CONCRETE_EVALUATESYM(Monoid.Any) -CONCRETE_EVALUATESYM(Ordering) -CONCRETE_EVALUATESYM_BV(IntN) -CONCRETE_EVALUATESYM_BV(WordN) -CONCRETE_EVALUATESYM(AlgReal) -#endif - -instance (Integral a, EvalSym a) => EvalSym (Ratio a) where - evalSym fillDefault model r = - evalSym fillDefault model (numerator r) - % evalSym fillDefault model (denominator r) - -instance (ValidFP eb fb) => EvalSym (FP eb fb) where - evalSym _ _ = id - --- Symbolic primitives -#define EVALUATE_SYM_SIMPLE(symtype) \ -instance EvalSym symtype where \ - evalSym fillDefault model (symtype t) = \ - symtype $ evalTerm fillDefault model HS.empty t - -#define EVALUATE_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => EvalSym (symtype n) where \ - evalSym fillDefault model (symtype t) = \ - symtype $ evalTerm fillDefault model HS.empty t - -#define EVALUATE_SYM_FUN(cop, op, cons) \ -instance EvalSym (op sa sb) where \ - evalSym fillDefault model (cons t) = \ - cons $ evalTerm fillDefault model HS.empty t - -#if 1 -EVALUATE_SYM_SIMPLE(SymBool) -EVALUATE_SYM_SIMPLE(SymInteger) -EVALUATE_SYM_SIMPLE(SymFPRoundingMode) -EVALUATE_SYM_SIMPLE(SymAlgReal) -EVALUATE_SYM_BV(SymIntN) -EVALUATE_SYM_BV(SymWordN) -EVALUATE_SYM_FUN((=->), (=~>), SymTabularFun) -EVALUATE_SYM_FUN((-->), (-~>), SymGeneralFun) -#endif - -instance (ValidFP eb sb) => EvalSym (SymFP eb sb) where - evalSym fillDefault model (SymFP t) = - SymFP $ evalTerm fillDefault model HS.empty t - --- Instances -deriveBuiltins - (ViaDefault ''EvalSym) - [''EvalSym] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''EvalSym1) - [''EvalSym, ''EvalSym1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- ExceptT -instance - (EvalSym1 m, EvalSym e, EvalSym a) => - EvalSym (ExceptT e m a) - where - evalSym = evalSym1 - {-# INLINE evalSym #-} - -instance (EvalSym1 m, EvalSym e) => EvalSym1 (ExceptT e m) where - liftEvalSym f fillDefault model = - ExceptT . liftEvalSym (liftEvalSym f) fillDefault model . runExceptT - {-# INLINE liftEvalSym #-} - --- MaybeT -instance (EvalSym1 m, EvalSym a) => EvalSym (MaybeT m a) where - evalSym = evalSym1 - {-# INLINE evalSym #-} - -instance (EvalSym1 m) => EvalSym1 (MaybeT m) where - liftEvalSym f fillDefault model = - MaybeT . liftEvalSym (liftEvalSym f) fillDefault model . runMaybeT - {-# INLINE liftEvalSym #-} - --- WriterT -instance - (EvalSym1 m, EvalSym s, EvalSym a) => - EvalSym (WriterLazy.WriterT s m a) - where - evalSym = evalSym1 - {-# INLINE evalSym #-} - -instance - (EvalSym1 m, EvalSym s) => - EvalSym1 (WriterLazy.WriterT s m) - where - liftEvalSym f fillDefault model = - WriterLazy.WriterT - . liftEvalSym (liftEvalSym2 f evalSym) fillDefault model - . WriterLazy.runWriterT - {-# INLINE liftEvalSym #-} - -instance - (EvalSym1 m, EvalSym s, EvalSym a) => - EvalSym (WriterStrict.WriterT s m a) - where - evalSym = evalSym1 - {-# INLINE evalSym #-} - -instance - (EvalSym1 m, EvalSym s) => - EvalSym1 (WriterStrict.WriterT s m) - where - liftEvalSym f fillDefault model = - WriterStrict.WriterT - . liftEvalSym (liftEvalSym2 f evalSym) fillDefault model - . WriterStrict.runWriterT - {-# INLINE liftEvalSym #-} - --- IdentityT -instance (EvalSym1 m, EvalSym a) => EvalSym (IdentityT m a) where - evalSym = evalSym1 - {-# INLINE evalSym #-} - -instance (EvalSym1 m) => EvalSym1 (IdentityT m) where - liftEvalSym f fillDefault model (IdentityT a) = - IdentityT $ liftEvalSym f fillDefault model a - {-# INLINE liftEvalSym #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (EvalSym (l a), EvalSym (r a)) => EvalSym (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (EvalSym1 l, EvalSym1 r) => EvalSym1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (EvalSym (l a), EvalSym (r a)) => EvalSym (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (EvalSym1 l, EvalSym1 r) => EvalSym1 (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (EvalSym (f (g a))) => EvalSym (Compose f g a) - -instance (EvalSym1 f, EvalSym1 g) => EvalSym1 (Compose f g) where - liftEvalSym f fillDefault m (Compose l) = - Compose $ liftEvalSym (liftEvalSym f) fillDefault m l - {-# INLINE liftEvalSym #-} - --- Const -deriving via (Default (Const a b)) instance (EvalSym a) => EvalSym (Const a b) - -deriving via (Default1 (Const a)) instance (EvalSym a) => EvalSym1 (Const a) - --- Alt -deriving via (Default (Alt f a)) instance (EvalSym (f a)) => EvalSym (Alt f a) - -deriving via (Default1 (Alt f)) instance (EvalSym1 f) => EvalSym1 (Alt f) - --- Ap -deriving via (Default (Ap f a)) instance (EvalSym (f a)) => EvalSym (Ap f a) - -deriving via (Default1 (Ap f)) instance (EvalSym1 f) => EvalSym1 (Ap f) - --- Generic -deriving via (Default (U1 p)) instance EvalSym (U1 p) - -deriving via (Default (V1 p)) instance EvalSym (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (EvalSym c) => EvalSym (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (EvalSym (f p)) => EvalSym (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (EvalSym (f p), EvalSym (g p)) => EvalSym ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (EvalSym (f p), EvalSym (g p)) => EvalSym ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (EvalSym p) => EvalSym (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (EvalSym (f p)) => EvalSym (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (EvalSym (f (g p))) => EvalSym ((f :.: g) p) - -instance EvalSym2 Either where - liftEvalSym2 f _ fillDefault model (Left a) = Left $ f fillDefault model a - liftEvalSym2 _ g fillDefault model (Right a) = - Right $ g fillDefault model a - {-# INLINE liftEvalSym2 #-} - -instance EvalSym2 (,) where - liftEvalSym2 f g fillDefault model (a, b) = - (f fillDefault model a, g fillDefault model b) - {-# INLINE liftEvalSym2 #-} - -instance (EvalSym a) => EvalSym2 ((,,) a) where - liftEvalSym2 f g fillDefault model (a, b, c) = - ( evalSym fillDefault model a, - f fillDefault model b, - g fillDefault model c - ) - {-# INLINE liftEvalSym2 #-} - -instance (EvalSym a, EvalSym b) => EvalSym2 ((,,,) a b) where - liftEvalSym2 f g fillDefault model (a, b, c, d) = - ( evalSym fillDefault model a, - evalSym fillDefault model b, - f fillDefault model c, - g fillDefault model d - ) - {-# INLINE liftEvalSym2 #-} - -instance (EvalSym a, EvalSym b) => EvalSym (a =-> b) where - evalSym fillDefault model (TabularFun s t) = - TabularFun - (evalSym fillDefault model s) - (evalSym fillDefault model t) - -instance (EvalSym (SymType b)) => EvalSym (a --> b) where - evalSym fillDefault model (GeneralFun s t) = - GeneralFun s $ - evalTerm fillDefault model (HS.singleton $ someTypedSymbol s) t +import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym +import Grisette.Internal.Internal.Impl.Core.Data.Class.EvalSym () diff --git a/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs b/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs --- a/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs @@ -1,20 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.ExtractSym @@ -42,641 +26,5 @@ ) where -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import qualified Data.HashSet as HS -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Maybe (fromJust) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator) -import qualified Data.Text as T -import Data.Typeable (type (:~~:) (HRefl)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Default1 (Default1, unDefault1), - Generic (Rep, from), - Generic1 (Rep1, from1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - type (:.:) (Comp1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) -import Grisette.Internal.SymPrim.Prim.Model - ( AnySymbolSet, - SymbolSet (SymbolSet), - ) -import Grisette.Internal.SymPrim.Prim.Term - ( IsSymbolKind (decideSymbolKind), - SymRep (SymType), - SymbolKind, - someTypedSymbol, - ) -import Grisette.Internal.SymPrim.Prim.TermUtils (extractTerm) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Grisette.Lib.Base --- >>> import Data.HashSet as HashSet --- >>> import Data.List (sort) - --- | Extracts all the symbols (symbolic constants) that are transitively --- contained in the given value. --- --- >>> extractSym ("a" :: SymBool) --- SymbolSet {a :: Bool} --- --- >>> extractSym (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: Union [SymBool]) --- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving ExtractSym via (Default X) -class ExtractSym a where - extractSym :: a -> AnySymbolSet - extractSym = fromJust . extractSymMaybe - {-# INLINE extractSym #-} - extractSymMaybe :: (IsSymbolKind knd) => a -> Maybe (SymbolSet knd) - --- | Lifting of 'ExtractSym' to unary type constructors. -class - (forall a. (ExtractSym a) => ExtractSym (f a)) => - ExtractSym1 f - where - -- | Lifts the 'extractSymMaybe' function to unary type constructors. - liftExtractSymMaybe :: - (IsSymbolKind knd) => - (a -> Maybe (SymbolSet knd)) -> - f a -> - Maybe (SymbolSet knd) - --- | Lift the standard 'extractSym' to unary type constructors. -extractSym1 :: - (ExtractSym1 f, ExtractSym a, IsSymbolKind knd) => - f a -> - SymbolSet knd -extractSym1 = fromJust . liftExtractSymMaybe extractSymMaybe -{-# INLINE extractSym1 #-} - --- | Lift the standard 'extractSymMaybe' to unary type constructors. -extractSymMaybe1 :: - (ExtractSym1 f, ExtractSym a, IsSymbolKind knd) => - f a -> - Maybe (SymbolSet knd) -extractSymMaybe1 = liftExtractSymMaybe extractSymMaybe -{-# INLINE extractSymMaybe1 #-} - --- | Lifting of 'ExtractSym' to binary type constructors. -class - (forall a. (ExtractSym a) => ExtractSym1 (f a)) => - ExtractSym2 f - where - -- | Lifts the 'extractSymMaybe' function to binary type constructors. - liftExtractSymMaybe2 :: - (IsSymbolKind knd) => - (a -> Maybe (SymbolSet knd)) -> - (b -> Maybe (SymbolSet knd)) -> - f a b -> - Maybe (SymbolSet knd) - --- | Lift the standard 'extractSym' to binary type constructors. -extractSym2 :: - (ExtractSym2 f, ExtractSym a, ExtractSym b, IsSymbolKind knd) => - f a b -> - SymbolSet knd -extractSym2 = fromJust . liftExtractSymMaybe2 extractSymMaybe extractSymMaybe - --- | Lift the standard 'extractSymMaybe' to binary type constructors. -extractSymMaybe2 :: - (ExtractSym2 f, ExtractSym a, ExtractSym b, IsSymbolKind knd) => - f a b -> - Maybe (SymbolSet knd) -extractSymMaybe2 = liftExtractSymMaybe2 extractSymMaybe extractSymMaybe -{-# INLINE extractSymMaybe2 #-} - --- Derivations - --- | The arguments to the generic 'extractSym' function. -data family ExtractSymArgs arity (knd :: SymbolKind) a :: Type - -data instance ExtractSymArgs Arity0 _ _ = ExtractSymArgs0 - -newtype instance ExtractSymArgs Arity1 knd a - = ExtractSymArgs1 (a -> Maybe (SymbolSet knd)) - --- | The class of types that can generically extract the symbols. -class GExtractSym arity f where - gextractSymMaybe :: - (IsSymbolKind knd) => - ExtractSymArgs arity knd a -> - f a -> - Maybe (SymbolSet knd) - -instance GExtractSym arity V1 where - gextractSymMaybe _ _ = Just mempty - {-# INLINE gextractSymMaybe #-} - -instance GExtractSym arity U1 where - gextractSymMaybe _ _ = Just mempty - {-# INLINE gextractSymMaybe #-} - -instance (GExtractSym arity a) => GExtractSym arity (M1 i c a) where - gextractSymMaybe args (M1 x) = gextractSymMaybe args x - {-# INLINE gextractSymMaybe #-} - -instance (ExtractSym a) => GExtractSym arity (K1 i a) where - gextractSymMaybe _ (K1 x) = extractSymMaybe x - {-# INLINE gextractSymMaybe #-} - -instance - (GExtractSym arity a, GExtractSym arity b) => - GExtractSym arity (a :+: b) - where - gextractSymMaybe args (L1 x) = gextractSymMaybe args x - gextractSymMaybe args (R1 x) = gextractSymMaybe args x - {-# INLINE gextractSymMaybe #-} - -instance - (GExtractSym arity a, GExtractSym arity b) => - GExtractSym arity (a :*: b) - where - gextractSymMaybe args (x :*: y) = - gextractSymMaybe args x <> gextractSymMaybe args y - {-# INLINE gextractSymMaybe #-} - -instance GExtractSym Arity1 Par1 where - gextractSymMaybe (ExtractSymArgs1 f) (Par1 x) = f x - {-# INLINE gextractSymMaybe #-} - -instance (ExtractSym1 a) => GExtractSym Arity1 (Rec1 a) where - gextractSymMaybe (ExtractSymArgs1 f) (Rec1 x) = - liftExtractSymMaybe f x - {-# INLINE gextractSymMaybe #-} - -instance - (ExtractSym1 f, GExtractSym Arity1 g) => - GExtractSym Arity1 (f :.: g) - where - gextractSymMaybe targs (Comp1 x) = - liftExtractSymMaybe (gextractSymMaybe targs) x - {-# INLINE gextractSymMaybe #-} - --- | Generic 'extractSym' function. -genericExtractSymMaybe :: - (Generic a, GExtractSym Arity0 (Rep a), IsSymbolKind knd) => - a -> - Maybe (SymbolSet knd) -genericExtractSymMaybe = gextractSymMaybe ExtractSymArgs0 . from - --- | Generic 'liftExtractSymMaybe' function. -genericLiftExtractSymMaybe :: - (Generic1 f, GExtractSym Arity1 (Rep1 f), IsSymbolKind knd) => - (a -> Maybe (SymbolSet knd)) -> - f a -> - Maybe (SymbolSet knd) -genericLiftExtractSymMaybe f = - gextractSymMaybe (ExtractSymArgs1 f) . from1 - -instance - (Generic a, GExtractSym Arity0 (Rep a)) => - ExtractSym (Default a) - where - extractSymMaybe = genericExtractSymMaybe . unDefault - {-# INLINE extractSymMaybe #-} - -instance - (Generic1 f, GExtractSym Arity1 (Rep1 f), ExtractSym a) => - ExtractSym (Default1 f a) - where - extractSymMaybe = extractSymMaybe1 - {-# INLINE extractSymMaybe #-} - -instance - (Generic1 f, GExtractSym Arity1 (Rep1 f)) => - ExtractSym1 (Default1 f) - where - liftExtractSymMaybe f = genericLiftExtractSymMaybe f . unDefault1 - {-# INLINE liftExtractSymMaybe #-} - -#define CONCRETE_EXTRACT_SYMBOLICS(type) \ -instance ExtractSym type where \ - extractSymMaybe _ = return mempty - -#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \ -instance (KnownNat n, 1 <= n) => ExtractSym (type n) where \ - extractSymMaybe _ = return mempty - -#if 1 -CONCRETE_EXTRACT_SYMBOLICS(Bool) -CONCRETE_EXTRACT_SYMBOLICS(Integer) -CONCRETE_EXTRACT_SYMBOLICS(Char) -CONCRETE_EXTRACT_SYMBOLICS(Int) -CONCRETE_EXTRACT_SYMBOLICS(Int8) -CONCRETE_EXTRACT_SYMBOLICS(Int16) -CONCRETE_EXTRACT_SYMBOLICS(Int32) -CONCRETE_EXTRACT_SYMBOLICS(Int64) -CONCRETE_EXTRACT_SYMBOLICS(Word) -CONCRETE_EXTRACT_SYMBOLICS(Word8) -CONCRETE_EXTRACT_SYMBOLICS(Word16) -CONCRETE_EXTRACT_SYMBOLICS(Word32) -CONCRETE_EXTRACT_SYMBOLICS(Word64) -CONCRETE_EXTRACT_SYMBOLICS(Float) -CONCRETE_EXTRACT_SYMBOLICS(Double) -CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) -CONCRETE_EXTRACT_SYMBOLICS(T.Text) -CONCRETE_EXTRACT_SYMBOLICS(FPRoundingMode) -CONCRETE_EXTRACT_SYMBOLICS(Monoid.All) -CONCRETE_EXTRACT_SYMBOLICS(Monoid.Any) -CONCRETE_EXTRACT_SYMBOLICS(Ordering) -CONCRETE_EXTRACT_SYMBOLICS_BV(WordN) -CONCRETE_EXTRACT_SYMBOLICS_BV(IntN) -CONCRETE_EXTRACT_SYMBOLICS(AlgReal) -#endif - -instance (ExtractSym a) => ExtractSym (Ratio a) where - extractSymMaybe a = - extractSymMaybe (numerator a) <> extractSymMaybe (denominator a) - {-# INLINE extractSymMaybe #-} - -instance (ValidFP eb sb) => ExtractSym (FP eb sb) where - extractSymMaybe _ = return mempty - -#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \ -instance ExtractSym symtype where \ - extractSymMaybe :: \ - forall knd. (IsSymbolKind knd) => symtype -> Maybe (SymbolSet knd); \ - extractSymMaybe (symtype t) = \ - case decideSymbolKind @knd of\ - Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \ - Right HRefl -> SymbolSet <$> extractTerm HS.empty t - -#define EXTRACT_SYMBOLICS_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ExtractSym (symtype n) where \ - extractSymMaybe :: \ - forall knd. (IsSymbolKind knd) => symtype n -> Maybe (SymbolSet knd); \ - extractSymMaybe (symtype t) = \ - case decideSymbolKind @knd of\ - Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \ - Right HRefl -> SymbolSet <$> extractTerm HS.empty t - -#define EXTRACT_SYMBOLICS_FUN(op, cons) \ -instance ExtractSym (op sa sb) where \ - extractSymMaybe :: \ - forall knd. (IsSymbolKind knd) => op sa sb -> Maybe (SymbolSet knd); \ - extractSymMaybe (cons t) = \ - case decideSymbolKind @knd of \ - Left HRefl -> Nothing; \ - Right HRefl -> SymbolSet <$> extractTerm HS.empty t - -#if 1 -EXTRACT_SYMBOLICS_SIMPLE(SymBool) -EXTRACT_SYMBOLICS_SIMPLE(SymInteger) -EXTRACT_SYMBOLICS_SIMPLE(SymFPRoundingMode) -EXTRACT_SYMBOLICS_SIMPLE(SymAlgReal) -EXTRACT_SYMBOLICS_BV(SymIntN) -EXTRACT_SYMBOLICS_BV(SymWordN) -EXTRACT_SYMBOLICS_FUN((=~>), SymTabularFun) -EXTRACT_SYMBOLICS_FUN((-~>), SymGeneralFun) -#endif - -instance (ValidFP eb fb) => ExtractSym (SymFP eb fb) where - extractSymMaybe :: - forall knd. (IsSymbolKind knd) => SymFP eb fb -> Maybe (SymbolSet knd) - extractSymMaybe (SymFP t) = - case decideSymbolKind @knd of - Left HRefl -> SymbolSet <$> extractTerm HS.empty t - Right HRefl -> SymbolSet <$> extractTerm HS.empty t - --- Instances -deriveBuiltins - (ViaDefault ''ExtractSym) - [''ExtractSym] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''ExtractSym1) - [''ExtractSym, ''ExtractSym1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- ExceptT -instance - (ExtractSym1 m, ExtractSym e, ExtractSym a) => - ExtractSym (ExceptT e m a) - where - extractSymMaybe = extractSymMaybe1 - {-# INLINE extractSymMaybe #-} - -instance - (ExtractSym1 m, ExtractSym e) => - ExtractSym1 (ExceptT e m) - where - liftExtractSymMaybe f (ExceptT v) = - liftExtractSymMaybe (liftExtractSymMaybe f) v - {-# INLINE liftExtractSymMaybe #-} - --- MaybeT -instance - (ExtractSym1 m, ExtractSym a) => - ExtractSym (MaybeT m a) - where - extractSymMaybe = extractSymMaybe1 - {-# INLINE extractSymMaybe #-} - -instance - (ExtractSym1 m) => - ExtractSym1 (MaybeT m) - where - liftExtractSymMaybe f (MaybeT v) = - liftExtractSymMaybe (liftExtractSymMaybe f) v - {-# INLINE liftExtractSymMaybe #-} - --- WriterT -instance - (ExtractSym1 m, ExtractSym w, ExtractSym a) => - ExtractSym (WriterLazy.WriterT w m a) - where - extractSymMaybe = extractSymMaybe1 - {-# INLINE extractSymMaybe #-} - -instance - (ExtractSym1 m, ExtractSym w) => - ExtractSym1 (WriterLazy.WriterT w m) - where - liftExtractSymMaybe f (WriterLazy.WriterT v) = - liftExtractSymMaybe (liftExtractSymMaybe2 f extractSymMaybe) v - {-# INLINE liftExtractSymMaybe #-} - -instance - (ExtractSym1 m, ExtractSym w, ExtractSym a) => - ExtractSym (WriterStrict.WriterT w m a) - where - extractSymMaybe = extractSymMaybe1 - {-# INLINE extractSymMaybe #-} - -instance - (ExtractSym1 m, ExtractSym w) => - ExtractSym1 (WriterStrict.WriterT w m) - where - liftExtractSymMaybe f (WriterStrict.WriterT v) = - liftExtractSymMaybe (liftExtractSymMaybe2 f extractSymMaybe) v - {-# INLINE liftExtractSymMaybe #-} - --- IdentityT -instance - (ExtractSym1 m, ExtractSym a) => - ExtractSym (IdentityT m a) - where - extractSymMaybe = extractSymMaybe1 - {-# INLINE extractSymMaybe #-} - -instance (ExtractSym1 m) => ExtractSym1 (IdentityT m) where - liftExtractSymMaybe f (IdentityT v) = liftExtractSymMaybe f v - {-# INLINE liftExtractSymMaybe #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (ExtractSym (l a), ExtractSym (r a)) => - ExtractSym (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (ExtractSym1 l, ExtractSym1 r) => - ExtractSym1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (ExtractSym (l a), ExtractSym (r a)) => - ExtractSym (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (ExtractSym1 l, ExtractSym1 r) => ExtractSym1 (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (ExtractSym (f (g a))) => ExtractSym (Compose f g a) - -instance - (ExtractSym1 f, ExtractSym1 g) => - ExtractSym1 (Compose f g) - where - liftExtractSymMaybe f (Compose l) = - liftExtractSymMaybe (liftExtractSymMaybe f) l - {-# INLINE liftExtractSymMaybe #-} - --- Const -deriving via - (Default (Const a b)) - instance - (ExtractSym a) => ExtractSym (Const a b) - -deriving via - (Default1 (Const a)) - instance - (ExtractSym a) => ExtractSym1 (Const a) - --- Alt -deriving via - (Default (Alt f a)) - instance - (ExtractSym (f a)) => ExtractSym (Alt f a) - -deriving via - (Default1 (Alt f)) - instance - (ExtractSym1 f) => ExtractSym1 (Alt f) - --- Ap -deriving via - (Default (Ap f a)) - instance - (ExtractSym (f a)) => ExtractSym (Ap f a) - -deriving via - (Default1 (Ap f)) - instance - (ExtractSym1 f) => ExtractSym1 (Ap f) - --- Generic -deriving via (Default (U1 p)) instance ExtractSym (U1 p) - -deriving via (Default (V1 p)) instance ExtractSym (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (ExtractSym c) => ExtractSym (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (ExtractSym (f p)) => ExtractSym (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (ExtractSym (f p), ExtractSym (g p)) => - ExtractSym ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (ExtractSym (f p), ExtractSym (g p)) => - ExtractSym ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (ExtractSym p) => ExtractSym (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (ExtractSym (f p)) => ExtractSym (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (ExtractSym (f (g p))) => ExtractSym ((f :.: g) p) - --- ExtractSym2 -instance ExtractSym2 Either where - liftExtractSymMaybe2 f _ (Left x) = f x - liftExtractSymMaybe2 _ g (Right y) = g y - {-# INLINE liftExtractSymMaybe2 #-} - -instance ExtractSym2 (,) where - liftExtractSymMaybe2 f g (x, y) = f x <> g y - {-# INLINE liftExtractSymMaybe2 #-} - -instance (ExtractSym a) => ExtractSym2 ((,,) a) where - liftExtractSymMaybe2 f g (x, y, z) = extractSymMaybe x <> f y <> g z - {-# INLINE liftExtractSymMaybe2 #-} - -instance - (ExtractSym a, ExtractSym b) => - ExtractSym2 ((,,,) a b) - where - liftExtractSymMaybe2 f g (x, y, z, w) = - extractSymMaybe x <> extractSymMaybe y <> f z <> g w - {-# INLINE liftExtractSymMaybe2 #-} - -instance (ExtractSym a, ExtractSym b) => ExtractSym (a =-> b) where - extractSymMaybe (TabularFun s t) = - extractSymMaybe s <> extractSymMaybe t - -instance (ExtractSym (SymType b)) => ExtractSym (a --> b) where - extractSymMaybe :: forall knd. (IsSymbolKind knd) => (a --> b) -> Maybe (SymbolSet knd) - extractSymMaybe (GeneralFun t f) = - case decideSymbolKind @knd of - Left HRefl -> Nothing - Right HRefl -> SymbolSet <$> extractTerm (HS.singleton $ someTypedSymbol t) f +import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym +import Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym () diff --git a/src/Grisette/Internal/Core/Data/Class/GenSym.hs b/src/Grisette/Internal/Core/Data/Class/GenSym.hs --- a/src/Grisette/Internal/Core/Data/Class/GenSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/GenSym.hs @@ -132,7 +132,7 @@ tryMerge, ) import Grisette.Internal.Core.Data.Symbol (Identifier) -import Grisette.Internal.Core.Data.UnionBase +import Grisette.Internal.Internal.Decl.Core.Data.UnionBase ( UnionBase (UnionIf, UnionSingle), ) import Grisette.Internal.SymPrim.BV (IntN, WordN) diff --git a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs --- a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs +++ b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs @@ -21,9 +21,14 @@ import Control.Monad.Identity (Identity (Identity)) import qualified Data.HashSet as HS +import Data.Proxy (Proxy) import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.SymPrim.FP (ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (freshArgSymbol, substTerm, type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.GeneralFun + ( freshArgSymbol, + substTerm, + type (-->) (GeneralFun), + ) import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm)) import Grisette.Internal.SymPrim.Prim.Term ( SupportedPrim (pevalITETerm), @@ -108,4 +113,8 @@ instance (ITEOp v) => ITEOp (Identity v) where symIte c (Identity t) (Identity f) = Identity $ symIte c t f + {-# INLINE symIte #-} + +instance ITEOp (Proxy a) where + symIte _ l _ = l {-# INLINE symIte #-} diff --git a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs --- a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs +++ b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs @@ -1,1187 +1,43 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.Mergeable --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.Mergeable - ( -- * Merging strategy - MergingStrategy (..), - - -- * Mergeable - Mergeable (..), - Mergeable1 (..), - rootStrategy1, - Mergeable2 (..), - rootStrategy2, - Mergeable3 (..), - rootStrategy3, - - -- * Generic 'Mergeable' - MergeableArgs (..), - GMergeable (..), - genericRootStrategy, - genericLiftRootStrategy, - - -- * Combinators for manually building merging strategies - wrapStrategy, - product2Strategy, - DynamicSortedIdx (..), - StrategyList (..), - buildStrategyList, - resolveStrategy, - resolveStrategy', - resolveMergeable1, - ) -where - -import Control.Exception - ( ArithException - ( Denormal, - DivideByZero, - LossOfPrecision, - Overflow, - RatioZeroDenominator, - Underflow - ), - ) -import Control.Monad.Cont (ContT (ContT)) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT, runIdentityT), - ) -import qualified Control.Monad.RWS.Lazy as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Classes - ( Eq1, - Ord1, - Show1, - compare1, - eq1, - showsPrec1, - ) -import Data.Functor.Compose (Compose (Compose, getCompose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap, Endo (Endo, appEndo)) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio) -import qualified Data.Text as T -import Data.Typeable - ( Typeable, - eqT, - type (:~:) (Refl), - ) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (+), type (<=)) -import Generics.Deriving - ( Default (Default), - Default1 (Default1), - Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1, unK1), - M1 (M1, unM1), - Par1 (Par1, unPar1), - Rec1 (Rec1, unRec1), - U1, - V1, - (:.:) (Comp1, unComp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Class.BitCast (bitCastOrCanonical) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.SymPrim.AlgReal (AlgReal, AlgRealPoly, RealPoint) -import Grisette.Internal.SymPrim.BV - ( IntN, - WordN, - ) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - withValidFPProofs, - ) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) -import Unsafe.Coerce (unsafeCoerce) - --- | Merging strategies. --- --- __You probably do not need to know the details of this type if you are only__ --- __going to use algebraic data types. You can get merging strategies for__ --- __them with type derivation.__ --- --- In Grisette, a merged union (if-then-else tree) follows the --- __/hierarchical sorted representation invariant/__ with regards to some --- merging strategy. --- --- A merging strategy encodes how to merge a __/subset/__ of the values of a --- given type. We have three types of merging strategies: --- --- * Simple strategy --- * Sorted strategy --- * No strategy --- --- The 'SimpleStrategy' merges values with a simple merge function. --- For example, --- --- * the symbolic boolean values can be directly merged with 'symIte'. --- --- * the set @{1}@, which is a subset of the values of the type @Integer@, --- can be simply merged as the set contains only a single value. --- --- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged --- by merging the wrapped symbolic boolean with 'symIte'. --- --- The 'SortedStrategy' merges values by first grouping the values with an --- indexing function, and the values with the same index will be organized as --- a sub-tree in the if-then-else structure of --- 'Grisette.Core.Data.UnionBase.UnionBase'. Each group (sub-tree) will be --- further merged with a sub-strategy for the index. --- The index type should be a totally ordered type (with the 'Ord' --- type class). Grisette will use the indexing function to partition the values --- into sub-trees, and organize them in a sorted way. The sub-trees will further --- be merged with the sub-strategies. For example, --- --- * all the integers can be merged with 'SortedStrategy' by indexing with --- the identity function and use the 'SimpleStrategy' shown before as the --- sub-strategies. --- --- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by --- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can --- then be merged with different simple strategies as sub-strategies. --- --- The 'NoStrategy' does not perform any merging. --- For example, we cannot merge values with function types that returns concrete --- lists. --- --- For ADTs, we can automatically derive the 'Mergeable' type class, which --- provides a merging strategy. --- --- If the derived version does not work for you, you should determine --- if your type can be directly merged with a merging function. If so, you can --- implement the merging strategy as a 'SimpleStrategy'. --- If the type cannot be directly merged with a merging function, but could be --- partitioned into subsets of values that can be simply merged with a function, --- you should implement the merging strategy as a 'SortedStrategy'. --- For easier building of the merging strategies, check out the combinators --- like `wrapStrategy`. --- --- For more details, please see the documents of the constructors, or refer to --- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). -data MergingStrategy a where - -- | Simple mergeable strategy. - -- - -- For symbolic booleans, we can implement its merge strategy as follows: - -- - -- > SimpleStrategy symIte :: MergingStrategy SymBool - SimpleStrategy :: - -- | Merge function. - (SymBool -> a -> a -> a) -> - MergingStrategy a - -- | Sorted mergeable strategy. - -- - -- For Integers, we can implement its merge strategy as follows: - -- - -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) - -- - -- For @Maybe SymBool@, we can implement its merge strategy as follows: - -- - -- > SortedStrategy - -- > (\case; Nothing -> False; Just _ -> True) - -- > (\idx -> - -- > if idx - -- > then SimpleStrategy $ \_ t _ -> t - -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ symIte cond l r) - SortedStrategy :: - (Ord idx, Typeable idx, Show idx) => - -- | Indexing function - (a -> idx) -> - -- | Sub-strategy function - (idx -> MergingStrategy a) -> - MergingStrategy a - -- | For preventing the merging intentionally. This could be - -- useful for keeping some value concrete and may help generate more efficient - -- formulas. - -- - -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for - -- details. - NoStrategy :: MergingStrategy a - --- | Each type is associated with a root merge strategy given by 'rootStrategy'. --- The root merge strategy should be able to merge every value of the type. --- Grisette will use the root merge strategy to merge the values of the type in --- a union. --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving Mergeable via (Default X) -class Mergeable a where - -- | The root merging strategy for the type. - rootStrategy :: MergingStrategy a - --- | Lifting of the 'Mergeable' class to unary type constructors. -class - (forall a. (Mergeable a) => Mergeable (u a)) => - Mergeable1 (u :: Type -> Type) - where - -- | Lift merge strategy through the type constructor. - liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) - --- | Lift the root merge strategy through the unary type constructor. -rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) -rootStrategy1 = liftRootStrategy rootStrategy -{-# INLINE rootStrategy1 #-} - --- | Workaround as GHC prior to 9.6 doesn't support quantified constraints --- reliably. --- --- Similar to https://github.com/haskell/core-libraries-committee/issues/10, --- which is only available with 9.6 or higher. -resolveMergeable1 :: - forall f a r. (Mergeable1 f, Mergeable a) => ((Mergeable (f a)) => r) -> r -resolveMergeable1 v = v - --- | Lifting of the 'Mergeable' class to binary type constructors. -class - (forall a. (Mergeable a) => Mergeable1 (u a)) => - Mergeable2 (u :: Type -> Type -> Type) - where - -- | Lift merge strategy through the type constructor. - liftRootStrategy2 :: - MergingStrategy a -> - MergingStrategy b -> - MergingStrategy (u a b) - --- | Lift the root merge strategy through the binary type constructor. -rootStrategy2 :: - (Mergeable a, Mergeable b, Mergeable2 u) => - MergingStrategy (u a b) -rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy -{-# INLINE rootStrategy2 #-} - --- | Lifting of the 'Mergeable' class to ternary type constructors. -class - (forall a. (Mergeable a) => Mergeable2 (u a)) => - Mergeable3 (u :: Type -> Type -> Type -> Type) - where - -- | Lift merge strategy through the type constructor. - liftRootStrategy3 :: - MergingStrategy a -> - MergingStrategy b -> - MergingStrategy c -> - MergingStrategy (u a b c) - --- | Lift the root merge strategy through the binary type constructor. -rootStrategy3 :: - (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => - MergingStrategy (u a b c) -rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy -{-# INLINE rootStrategy3 #-} - --- | Useful utility function for building merge strategies manually. --- --- For example, to build the merge strategy for the just branch of @Maybe a@, --- one could write --- --- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) -wrapStrategy :: - -- | The merge strategy to be wrapped - MergingStrategy a -> - -- | The wrap function - (a -> b) -> - -- | The unwrap function, which does not have to be defined for every value - (b -> a) -> - MergingStrategy b -wrapStrategy (SimpleStrategy m) wrap unwrap = - SimpleStrategy - ( \cond ifTrue ifFalse -> - wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) - ) -wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = - SortedStrategy - (idxFun . unwrap) - (\idx -> wrapStrategy (substrategy idx) wrap unwrap) -wrapStrategy NoStrategy _ _ = NoStrategy -{-# INLINE wrapStrategy #-} - --- | Useful utility function for building merge strategies for product types --- manually. --- --- For example, to build the merge strategy for the following product type, --- one could write --- --- > data X = X { x1 :: Int, x2 :: Bool } --- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy --- > :: MergingStrategy X -product2Strategy :: - -- | The wrap function - (a -> b -> r) -> - -- | The unwrap function, which does not have to be defined for every value - (r -> (a, b)) -> - -- | The first merge strategy to be wrapped - MergingStrategy a -> - -- | The second merge strategy to be wrapped - MergingStrategy b -> - MergingStrategy r -product2Strategy wrap unwrap strategy1 strategy2 = - case (strategy1, strategy2) of - (NoStrategy, _) -> NoStrategy - (_, NoStrategy) -> NoStrategy - (SimpleStrategy m1, SimpleStrategy m2) -> - SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of - ((hdt, tlt), (hdf, tlf)) -> - wrap (m1 cond hdt hdf) (m2 cond tlt tlf) - (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> - SortedStrategy - (idxf . snd . unwrap) - (product2Strategy wrap unwrap s1 . subf) - (SortedStrategy idxf subf, s2) -> - SortedStrategy - (idxf . fst . unwrap) - (\idx -> product2Strategy wrap unwrap (subf idx) s2) -{-# INLINE product2Strategy #-} - --- Derivations - --- | The arguments to the generic merging strategy function. -data family MergeableArgs arity a :: Type - -data instance MergeableArgs Arity0 _ = MergeableArgs0 - -newtype instance MergeableArgs Arity1 a = MergeableArgs1 (MergingStrategy a) - --- | The class of types that can be generically merged. -class GMergeable arity f where - grootStrategy :: MergeableArgs arity a -> MergingStrategy (f a) - -instance GMergeable arity V1 where - grootStrategy _ = SimpleStrategy (\_ t _ -> t) - {-# INLINE grootStrategy #-} - -instance GMergeable arity U1 where - grootStrategy _ = SimpleStrategy (\_ t _ -> t) - {-# INLINE grootStrategy #-} - -instance - (GMergeable arity a, GMergeable arity b) => - GMergeable arity (a :*: b) - where - grootStrategy args = - product2Strategy - (:*:) - (\(a :*: b) -> (a, b)) - (grootStrategy args) - (grootStrategy args) - {-# INLINE grootStrategy #-} - -instance - (GMergeable arity a, GMergeable arity b) => - GMergeable arity (a :+: b) - where - grootStrategy args = - SortedStrategy - ( \case - L1 _ -> False - R1 _ -> True - ) - ( \idx -> - if not idx - then - wrapStrategy - (grootStrategy args) - L1 - (\case (L1 v) -> v; _ -> error "Should not happen") - else - wrapStrategy - (grootStrategy args) - R1 - (\case (R1 v) -> v; _ -> error "Should not happen") - ) - {-# INLINE grootStrategy #-} - -instance (GMergeable arity a) => GMergeable arity (M1 i c a) where - grootStrategy arg = wrapStrategy (grootStrategy arg) M1 unM1 - {-# INLINE grootStrategy #-} - -instance (Mergeable c) => GMergeable arity (K1 i c) where - grootStrategy _ = wrapStrategy rootStrategy K1 unK1 - {-# INLINE grootStrategy #-} - -instance GMergeable Arity1 Par1 where - grootStrategy (MergeableArgs1 strategy) = wrapStrategy strategy Par1 unPar1 - {-# INLINE grootStrategy #-} - -instance (Mergeable1 f) => GMergeable Arity1 (Rec1 f) where - grootStrategy (MergeableArgs1 m) = - wrapStrategy (liftRootStrategy m) Rec1 unRec1 - {-# INLINE grootStrategy #-} - -instance - (Mergeable1 f, GMergeable Arity1 g) => - GMergeable Arity1 (f :.: g) - where - grootStrategy targs = - wrapStrategy (liftRootStrategy (grootStrategy targs)) Comp1 unComp1 - {-# INLINE grootStrategy #-} - -instance (Generic a, GMergeable Arity0 (Rep a)) => Mergeable (Default a) where - rootStrategy = unsafeCoerce (genericRootStrategy :: MergingStrategy a) - {-# INLINE rootStrategy #-} - --- | Generic 'rootStrategy'. -genericRootStrategy :: - (Generic a, GMergeable Arity0 (Rep a)) => MergingStrategy a -genericRootStrategy = wrapStrategy (grootStrategy MergeableArgs0) to from -{-# INLINE genericRootStrategy #-} - -instance - (Generic1 f, GMergeable Arity1 (Rep1 f), Mergeable a) => - Mergeable (Default1 f a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Generic1 f, GMergeable Arity1 (Rep1 f)) => Mergeable1 (Default1 f) where - liftRootStrategy (m :: MergingStrategy a) = - unsafeCoerce (genericLiftRootStrategy m :: MergingStrategy (f a)) - {-# INLINE liftRootStrategy #-} - --- | Generic 'liftRootStrategy'. -genericLiftRootStrategy :: - (Generic1 f, GMergeable Arity1 (Rep1 f)) => - MergingStrategy a -> - MergingStrategy (f a) -genericLiftRootStrategy m = - wrapStrategy (grootStrategy $ MergeableArgs1 m) to1 from1 -{-# INLINE genericLiftRootStrategy #-} - --- | Helper type for combining arbitrary number of indices into one. --- Useful when trying to write efficient merge strategy for lists/vectors. -data DynamicSortedIdx where - DynamicSortedIdx :: forall idx. (Show idx, Ord idx, Typeable idx) => idx -> DynamicSortedIdx - -instance Eq DynamicSortedIdx where - (DynamicSortedIdx (a :: a)) == (DynamicSortedIdx (b :: b)) = case eqT @a @b of - Just Refl -> a == b - _ -> False - {-# INLINE (==) #-} - -instance Ord DynamicSortedIdx where - compare (DynamicSortedIdx (a :: a)) (DynamicSortedIdx (b :: b)) = case eqT @a @b of - Just Refl -> compare a b - _ -> error "This Ord is incomplete" - {-# INLINE compare #-} - -instance Show DynamicSortedIdx where - show (DynamicSortedIdx a) = show a - --- | Resolves the indices and the terminal merge strategy for a value of some --- 'Mergeable' type. -resolveStrategy :: - forall x. - MergingStrategy x -> - x -> - ([DynamicSortedIdx], MergingStrategy x) -resolveStrategy s x = resolveStrategy' x s -{-# INLINE resolveStrategy #-} - --- | Resolves the indices and the terminal merge strategy for a value given a --- merge strategy for its type. -resolveStrategy' :: - forall x. x -> MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) -resolveStrategy' x = go - where - go :: MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) - go (SortedStrategy idxFun subStrategy) = case go ss of - (idxs, r) -> (DynamicSortedIdx idx : idxs, r) - where - idx = idxFun x - ss = subStrategy idx - go s = ([], s) -{-# INLINE resolveStrategy' #-} - -#define CONCRETE_ORD_MERGEABLE(type) \ -instance Mergeable type where \ - rootStrategy = \ - let sub = SimpleStrategy $ \_ t _ -> t \ - in SortedStrategy id $ const sub - -#define CONCRETE_ORD_MERGEABLE_BV(type) \ -instance (KnownNat n, 1 <= n) => Mergeable (type n) where \ - rootStrategy = \ - let sub = SimpleStrategy $ \_ t _ -> t \ - in SortedStrategy id $ const sub - -#if 1 -CONCRETE_ORD_MERGEABLE(Bool) -CONCRETE_ORD_MERGEABLE(Integer) -CONCRETE_ORD_MERGEABLE(Char) -CONCRETE_ORD_MERGEABLE(Int) -CONCRETE_ORD_MERGEABLE(Int8) -CONCRETE_ORD_MERGEABLE(Int16) -CONCRETE_ORD_MERGEABLE(Int32) -CONCRETE_ORD_MERGEABLE(Int64) -CONCRETE_ORD_MERGEABLE(Word) -CONCRETE_ORD_MERGEABLE(Word8) -CONCRETE_ORD_MERGEABLE(Word16) -CONCRETE_ORD_MERGEABLE(Word32) -CONCRETE_ORD_MERGEABLE(Word64) -CONCRETE_ORD_MERGEABLE(Float) -CONCRETE_ORD_MERGEABLE(Double) -CONCRETE_ORD_MERGEABLE(B.ByteString) -CONCRETE_ORD_MERGEABLE(T.Text) -CONCRETE_ORD_MERGEABLE(FPRoundingMode) -CONCRETE_ORD_MERGEABLE(Monoid.All) -CONCRETE_ORD_MERGEABLE(Monoid.Any) -CONCRETE_ORD_MERGEABLE(Ordering) -CONCRETE_ORD_MERGEABLE_BV(WordN) -CONCRETE_ORD_MERGEABLE_BV(IntN) -#endif - -instance (Integral a, Typeable a, Show a) => Mergeable (Ratio a) where - rootStrategy = - let sub = SimpleStrategy $ \_ t _ -> t - in SortedStrategy id $ const sub - -instance (ValidFP eb sb) => Mergeable (FP eb sb) where - rootStrategy = - let sub = SimpleStrategy $ \_ t _ -> t - in withValidFPProofs @eb @sb - $ SortedStrategy - (\fp -> (bitCastOrCanonical fp :: WordN (eb + sb))) - $ const sub - -instance Mergeable (a =-> b) where - rootStrategy = NoStrategy - -instance Mergeable (a --> b) where - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_SIMPLE(symtype) \ -instance Mergeable symtype where \ - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_FUN(cop, op, consop) \ -instance Mergeable (op sa sb) where \ - rootStrategy = SimpleStrategy symIte - -#if 1 -MERGEABLE_SIMPLE(SymBool) -MERGEABLE_SIMPLE(SymInteger) -MERGEABLE_SIMPLE(SymFPRoundingMode) -MERGEABLE_SIMPLE(SymAlgReal) -MERGEABLE_BV(SymIntN) -MERGEABLE_BV(SymWordN) -MERGEABLE_FUN((=->), (=~>), SymTabularFun) -MERGEABLE_FUN((-->), (-~>), SymGeneralFun) -#endif - -instance (ValidFP eb sb) => Mergeable (SymFP eb sb) where - rootStrategy = SimpleStrategy symIte - --- function -instance (Mergeable b) => Mergeable (a -> b) where - rootStrategy = case rootStrategy @b of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 ((->) a) where - liftRootStrategy ms = case ms of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE liftRootStrategy #-} - -instance Mergeable2 ((->)) where - liftRootStrategy2 _ ms = case ms of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE liftRootStrategy2 #-} - --- List - --- | Helper type for building efficient merge strategy for list-like containers. -data StrategyList container where - StrategyList :: - forall a container. - container [DynamicSortedIdx] -> - container (MergingStrategy a) -> - StrategyList container - --- | Helper function for building efficient merge strategy for list-like --- containers. -buildStrategyList :: - forall a container. - (Functor container) => - MergingStrategy a -> - container a -> - StrategyList container -buildStrategyList s l = StrategyList idxs strategies - where - r = resolveStrategy s <$> l - idxs = fst <$> r - strategies = snd <$> r -{-# INLINE buildStrategyList #-} - -instance (Eq1 container) => Eq (StrategyList container) where - (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 - {-# INLINE (==) #-} - -instance (Ord1 container) => Ord (StrategyList container) where - compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 - {-# INLINE compare #-} - -instance (Show1 container) => Show (StrategyList container) where - showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 - {-# INLINE showsPrec #-} - -instance (Mergeable a) => Mergeable [a] where - rootStrategy = case rootStrategy :: MergingStrategy a of - SimpleStrategy m -> - SortedStrategy length $ \_ -> - SimpleStrategy $ \cond -> zipWith (m cond) - NoStrategy -> - SortedStrategy length $ const NoStrategy - _ -> SortedStrategy length $ \_ -> - SortedStrategy (buildStrategyList rootStrategy) $ - \(StrategyList _ strategies) -> - let s :: [MergingStrategy a] = unsafeCoerce strategies - allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s - in if allSimple - then SimpleStrategy $ \cond l r -> - ( \case - (SimpleStrategy f, l1, r1) -> f cond l1 r1 - _ -> error "impossible" - ) - <$> zip3 s l r - else NoStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 [] where - liftRootStrategy (ms :: MergingStrategy a) = case ms of - SimpleStrategy m -> - SortedStrategy length $ \_ -> - SimpleStrategy $ \cond -> zipWith (m cond) - NoStrategy -> - SortedStrategy length $ const NoStrategy - _ -> SortedStrategy length $ \_ -> - SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> - let s :: [MergingStrategy a] = unsafeCoerce strategies - allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s - in if allSimple - then SimpleStrategy $ \cond l r -> - ( \case - (SimpleStrategy f, l1, r1) -> f cond l1 r1 - _ -> error "impossible" - ) - <$> zip3 s l r - else NoStrategy - {-# INLINE liftRootStrategy #-} - --- (,) -instance (Mergeable a, Mergeable b) => Mergeable (a, b) where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable a) => Mergeable1 ((,) a) where - liftRootStrategy = liftRootStrategy2 rootStrategy - {-# INLINE liftRootStrategy #-} - -instance Mergeable2 (,) where - liftRootStrategy2 = product2Strategy (,) id - {-# INLINE liftRootStrategy2 #-} - --- (,,) -instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable ((,,) a b c) where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable a, Mergeable b) => Mergeable1 ((,,) a b) where - liftRootStrategy = liftRootStrategy2 rootStrategy - {-# INLINE liftRootStrategy #-} - -instance (Mergeable a) => Mergeable2 ((,,) a) where - liftRootStrategy2 = liftRootStrategy3 rootStrategy - {-# INLINE liftRootStrategy2 #-} - -instance Mergeable3 (,,) where - liftRootStrategy3 m1 m2 m3 = - product2Strategy - (\a (b, c) -> (a, b, c)) - (\(a, b, c) -> (a, (b, c))) - m1 - (liftRootStrategy2 m2 m3) - {-# INLINE liftRootStrategy3 #-} - --- (,,,) -instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => - Mergeable ((,,,) a b c d) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance - (Mergeable a, Mergeable b, Mergeable c) => - Mergeable1 ((,,,) a b c) - where - liftRootStrategy = liftRootStrategy2 rootStrategy - {-# INLINE liftRootStrategy #-} - -instance (Mergeable a, Mergeable b) => Mergeable2 ((,,,) a b) where - liftRootStrategy2 = liftRootStrategy3 rootStrategy - {-# INLINE liftRootStrategy2 #-} - -instance (Mergeable a) => Mergeable3 ((,,,) a) where - liftRootStrategy3 m1 m2 m3 = - product2Strategy - (\(a, b) (c, d) -> (a, b, c, d)) - (\(a, b, c, d) -> ((a, b), (c, d))) - (liftRootStrategy m1) - (liftRootStrategy2 m2 m3) - {-# INLINE liftRootStrategy3 #-} - --- Instances -deriveBuiltins - (ViaDefault ''Mergeable) - [''Mergeable] - [ ''Maybe, - ''Either, - ''AlgRealPoly, - ''RealPoint, - ''AlgReal, - ''(), - -- The following three are implemented by hand because they need to be - -- consistent with Mergeable2 instances. - -- ''(,), - -- ''(,,), - -- ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''Mergeable1) - [''Mergeable, ''Mergeable1] - [ ''Maybe, - ''Either, - -- The following three are implemented by hand because they need to be - -- consistent with Mergeable2 instances. - -- ''(,), - -- ''(,,), - -- ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- MaybeT -instance (Mergeable1 m, Mergeable a) => Mergeable (MaybeT m a) where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (MaybeT m) where - liftRootStrategy m = - wrapStrategy (liftRootStrategy (liftRootStrategy m)) MaybeT runMaybeT - {-# INLINE liftRootStrategy #-} - --- ExceptT -instance - (Mergeable1 m, Mergeable e, Mergeable a) => - Mergeable (ExceptT e m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable e) => Mergeable1 (ExceptT e m) where - liftRootStrategy m = - wrapStrategy (liftRootStrategy (liftRootStrategy m)) ExceptT runExceptT - {-# INLINE liftRootStrategy #-} - --- state -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (StateLazy.StateT s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateLazy.StateT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) - StateLazy.StateT - StateLazy.runStateT - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (StateStrict.StateT s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable1 m) => - Mergeable1 (StateStrict.StateT s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) - StateStrict.StateT - StateStrict.runStateT - {-# INLINE liftRootStrategy #-} - --- writer -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (WriterLazy.WriterT s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable1 m) => - Mergeable1 (WriterLazy.WriterT s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy2 m rootStrategy)) - WriterLazy.WriterT - WriterLazy.runWriterT - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (WriterStrict.WriterT s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable1 m) => - Mergeable1 (WriterStrict.WriterT s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy2 m rootStrategy)) - WriterStrict.WriterT - WriterStrict.runWriterT - {-# INLINE liftRootStrategy #-} - --- reader -instance - (Mergeable a, Mergeable1 m) => - Mergeable (ReaderT s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy m)) - ReaderT - runReaderT - {-# INLINE liftRootStrategy #-} - --- IdentityT -instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (IdentityT m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT - {-# INLINE liftRootStrategy #-} - --- ContT -instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where - rootStrategy = - wrapStrategy - (liftRootStrategy rootStrategy1) - ContT - (\(ContT v) -> v) - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where - liftRootStrategy _ = - wrapStrategy - (liftRootStrategy rootStrategy1) - ContT - (\(ContT v) -> v) - {-# INLINE liftRootStrategy #-} - --- RWS -instance - (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => - Mergeable (RWSLazy.RWST r w s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable1 m) => - Mergeable1 (RWSLazy.RWST r w s m) - where - liftRootStrategy m = - wrapStrategy - ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ - liftRootStrategy3 m rootStrategy rootStrategy - ) - RWSLazy.RWST - (\(RWSLazy.RWST rws) -> rws) - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => - Mergeable (RWSStrict.RWST r w s m a) - where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable1 m) => - Mergeable1 (RWSStrict.RWST r w s m) - where - liftRootStrategy m = - wrapStrategy - ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ - liftRootStrategy3 m rootStrategy rootStrategy - ) - RWSStrict.RWST - (\(RWSStrict.RWST rws) -> rws) - {-# INLINE liftRootStrategy #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (Mergeable (l a), Mergeable (r a)) => Mergeable (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (Mergeable1 l, Mergeable1 r) => Mergeable1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (Mergeable (l a), Mergeable (r a)) => Mergeable (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (Mergeable (f (g a))) => Mergeable (Compose f g a) - -instance (Mergeable1 f, Mergeable1 g) => Mergeable1 (Compose f g) where - liftRootStrategy s = - wrapStrategy (liftRootStrategy (liftRootStrategy s)) Compose getCompose - {-# INLINE liftRootStrategy #-} - --- Const -deriving via - (Default (Const a b)) - instance - (Mergeable a) => Mergeable (Const a b) - -deriving via - (Default1 (Const a)) - instance - (Mergeable a) => Mergeable1 (Const a) - --- Alt -deriving via - (Default (Alt f a)) - instance - (Mergeable (f a)) => Mergeable (Alt f a) - -deriving via - (Default1 (Alt f)) - instance - (Mergeable1 f) => Mergeable1 (Alt f) - --- Ap -deriving via - (Default (Ap f a)) - instance - (Mergeable (f a)) => Mergeable (Ap f a) - -deriving via - (Default1 (Ap f)) - instance - (Mergeable1 f) => Mergeable1 (Ap f) - --- Endo -instance (Mergeable a) => Mergeable (Endo a) where - rootStrategy = rootStrategy1 - {-# INLINE rootStrategy #-} - -instance Mergeable1 Endo where - liftRootStrategy strategy = - wrapStrategy (liftRootStrategy strategy) Endo appEndo - --- Generic -deriving via (Default (U1 p)) instance Mergeable (U1 p) - -deriving via (Default (V1 p)) instance Mergeable (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (Mergeable c) => Mergeable (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (Mergeable (f p)) => Mergeable (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (Mergeable (f p), Mergeable (g p)) => Mergeable ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (Mergeable (f p), Mergeable (g p)) => Mergeable ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (Mergeable p) => Mergeable (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (Mergeable (f p)) => Mergeable (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (Mergeable (f (g p))) => Mergeable ((f :.: g) p) - --- Exceptions -instance Mergeable ArithException where - rootStrategy = - SortedStrategy - ( \case - Overflow -> 0 :: Int - Underflow -> 1 :: Int - LossOfPrecision -> 2 :: Int - DivideByZero -> 3 :: Int - Denormal -> 4 :: Int - RatioZeroDenominator -> 5 :: Int - ) - (const $ SimpleStrategy $ \_ l _ -> l) - -instance Mergeable2 Either where - liftRootStrategy2 m1 m2 = - SortedStrategy - ( \case - Left _ -> False - Right _ -> True - ) - ( \case - False -> wrapStrategy m1 Left (\case (Left v) -> v; _ -> undefined) - True -> wrapStrategy m2 Right (\case (Right v) -> v; _ -> undefined) - ) - {-# INLINE liftRootStrategy2 #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Mergeable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Mergeable + ( -- * Merging strategy + MergingStrategy (..), + + -- * Mergeable + Mergeable (..), + Mergeable1 (..), + rootStrategy1, + Mergeable2 (..), + rootStrategy2, + Mergeable3 (..), + rootStrategy3, + + -- * Generic 'Mergeable' + MergeableArgs (..), + GMergeable (..), + genericRootStrategy, + genericLiftRootStrategy, + + -- * Combinators for manually building merging strategies + wrapStrategy, + product2Strategy, + DynamicSortedIdx (..), + StrategyList (..), + buildStrategyList, + resolveStrategy, + resolveStrategy', + resolveMergeable1, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable +import Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable () diff --git a/src/Grisette/Internal/Core/Data/Class/PPrint.hs b/src/Grisette/Internal/Core/Data/Class/PPrint.hs --- a/src/Grisette/Internal/Core/Data/Class/PPrint.hs +++ b/src/Grisette/Internal/Core/Data/Class/PPrint.hs @@ -1,21 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | @@ -66,879 +49,9 @@ #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter -import Prettyprinter.Render.String (renderString) -import Prettyprinter.Render.Text (renderStrict) #else import Data.Text.Prettyprint.Doc as Prettyprinter -import Data.Text.Prettyprint.Doc.Render.String (renderString) -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) #endif -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import qualified Data.HashMap.Lazy as HM -import qualified Data.HashSet as HS -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( C1, - Constructor (conFixity, conIsRecord, conName), - D1, - Fixity (Infix, Prefix), - Generic (Rep, from), - Generic1 (Rep1, from1), - K1 (K1), - M1 (M1), - Par1 (Par1, unPar1), - Rec1 (Rec1, unRec1), - S1, - Selector (selName), - U1 (U1), - V1, - (:.:) (Comp1, unComp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.Real (ratioPrec, ratioPrec1) -import GHC.Stack (HasCallStack) -import GHC.TypeLits (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Default1 (Default1, unDefault1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.Prim.Internal.Term () -import Grisette.Internal.SymPrim.Prim.Model - ( Model (Model), - SymbolSet (SymbolSet), - ) -import Grisette.Internal.SymPrim.Prim.Term - ( ModelValue, - SomeTypedSymbol (SomeTypedSymbol), - TypedSymbol (unTypedSymbol), - prettyPrintTerm, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- | Pretty printing of values. --- --- This class is similar to the 'Pretty' class from the "Prettyprinter" package, --- but it also provides pretty printing with a given precedence level. --- --- We are able to derive instances of this class for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving PPrint via (Default X) --- --- The derived instance will pretty print the value with a format similar to the --- one used by ormolu. -class PPrint a where - pformat :: a -> Doc ann - pformatPrec :: Int -> a -> Doc ann - pformatList :: [a] -> Doc ann - pformatList = align . prettyPrintList . map pformat - - pformat = pformatPrec 0 - pformatPrec _ = pformat - - {-# MINIMAL pformat | pformatPrec #-} - -pformatListLike :: Doc ann -> Doc ann -> [Doc ann] -> Doc ann -pformatListLike ldelim rdelim l - | null l = ldelim <> rdelim - | length l == 1 = - align $ group $ vcat [ldelim <> flatAlt " " "" <> head l, rdelim] - | otherwise = - groupedEnclose ldelim rdelim . align . vcat $ - ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l] - -prettyPrintList :: [Doc ann] -> Doc ann -prettyPrintList = pformatListLike "[" "]" - -prettyPrintTuple :: [Doc ann] -> Doc ann -prettyPrintTuple l - | length l >= 2 = - groupedEnclose "(" ")" . align . vcat $ - ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l] - | otherwise = error "Tuple must have at least 2 elements" - -instance PPrint Char where - pformat = viaShow - pformatList v = pretty (fromString v :: T.Text) - -instance (PPrint a) => PPrint [a] where - pformat = pformatList - --- | Convenience function to layout and render a 'Doc' to 'T.Text'. --- --- You can control the layout with t'LayoutOptions'. -docToTextWith :: LayoutOptions -> Doc ann -> T.Text -docToTextWith options = renderStrict . layoutPretty options - --- | Convenience function to layout and render a 'Doc' to 'T.Text'. --- --- You can control the layout with a single number of the width limit. -docToTextWithWidth :: Int -> Doc ann -> T.Text -docToTextWithWidth n - | n <= 0 = docToTextWith (LayoutOptions Unbounded) - | otherwise = docToTextWith (LayoutOptions $ AvailablePerLine n 1.0) - --- | Convenience function to layout and render a 'Doc' to 'T.Text'. --- --- The default layout options 'defaultLayoutOptions' are used. -docToText :: Doc ann -> T.Text -docToText = docToTextWith defaultLayoutOptions - --- | Convenience function to format a value to 'T.Text'. --- --- You can control the layout with t'LayoutOptions'. -pformatTextWith :: (PPrint a) => LayoutOptions -> a -> T.Text -pformatTextWith options = docToTextWith options . pformat - --- | Convenience function to format a value to 'T.Text'. --- --- You can control the layout with a single number of the width limit. -pformatTextWithWidth :: (PPrint a) => Int -> a -> T.Text -pformatTextWithWidth n = docToTextWithWidth n . pformat - --- | Convenience function to format a value to 'T.Text'. --- --- The default layout options 'defaultLayoutOptions' are used. -pformatText :: (PPrint a) => a -> T.Text -pformatText = docToText . pformat - --- | Pretty print a value to the standard output. -pprint :: (PPrint a) => a -> IO () -pprint = putStrLn . renderString . layoutPretty defaultLayoutOptions . pformat - --- | Lifting of the 'PPrint' class to unary type constructors. -class (forall a. (PPrint a) => PPrint (f a)) => PPrint1 f where - -- | Lift a pretty-printer to a unary type constructor. - liftPFormatPrec :: - (Int -> a -> Doc ann) -> ([a] -> Doc ann) -> Int -> f a -> Doc ann - - -- | Lift a pretty-printer to list of values with unary type constructors. - liftPFormatList :: - (Int -> a -> Doc ann) -> ([a] -> Doc ann) -> [f a] -> Doc ann - liftPFormatList f l = align . prettyPrintList . map (liftPFormatPrec f l 0) - -instance PPrint1 [] where - liftPFormatPrec _ l _ = l - liftPFormatList _ l = prettyPrintList . fmap l - --- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to unary --- type constructors. -pformatPrec1 :: (PPrint1 f, PPrint a) => Int -> f a -> Doc ann -pformatPrec1 = liftPFormatPrec pformatPrec pformatList -{-# INLINE pformatPrec1 #-} - --- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to list of --- values with unary type constructors. -pformatList1 :: (PPrint1 f, PPrint a) => [f a] -> Doc ann -pformatList1 = liftPFormatList pformatPrec pformatList -{-# INLINE pformatList1 #-} - --- | Lifting of the 'PPrint' class to binary type constructors. -class - ( forall a. (PPrint a) => PPrint1 (f a), - forall a b. (PPrint a, PPrint b) => PPrint (f a b) - ) => - PPrint2 f - where - -- | Lift two pretty-printers to a binary type constructor. - liftPFormatPrec2 :: - (Int -> a -> Doc ann) -> - ([a] -> Doc ann) -> - (Int -> b -> Doc ann) -> - ([b] -> Doc ann) -> - Int -> - f a b -> - Doc ann - - -- | Lift two pretty-printers to list of values with binary type constructors. - liftPFormatList2 :: - (Int -> a -> Doc ann) -> - ([a] -> Doc ann) -> - (Int -> b -> Doc ann) -> - ([b] -> Doc ann) -> - [f a b] -> - Doc ann - liftPFormatList2 fa fb la lb = - align . prettyPrintList . map (liftPFormatPrec2 fa fb la lb 0) - --- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to binary --- type constructors. -pformatPrec2 :: (PPrint2 f, PPrint a, PPrint b) => Int -> f a b -> Doc ann -pformatPrec2 = liftPFormatPrec2 pformatPrec pformatList pformatPrec pformatList -{-# INLINE pformatPrec2 #-} - --- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to list of --- values with binary type constructors. -pformatList2 :: (PPrint2 f, PPrint a, PPrint b) => [f a b] -> Doc ann -pformatList2 = liftPFormatList2 pformatPrec pformatList pformatPrec pformatList -{-# INLINE pformatList2 #-} - --- | The arguments to the generic 'PPrint' class. -data family PPrintArgs arity a ann :: Type - -data instance PPrintArgs Arity0 _ _ = PPrintArgs0 - -data instance PPrintArgs Arity1 a ann - = PPrintArgs1 - ((Int -> a -> Doc ann)) - (([a] -> Doc ann)) - --- | Controls how to pretty-print a generic representation. -data PPrintType = Rec | Tup | Pref | Inf String Int - deriving (Show, Eq) - --- | Enclose a document with left and right documents. --- --- The pretty printer will try to layout the document in a single line, but the --- right document may be split to a newline. -groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann -groupedEnclose l r d = group $ align $ vcat [l <> flatAlt " " "" <> align d, r] - --- | Conditionally enclose a document with left and right documents. --- --- If the condition is 'True', then this function is equivalent to --- 'groupedEnclose'. -condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann -condEnclose b = if b then groupedEnclose else const $ const id - --- | Pretty print a list of fields with a constructor. --- --- Aligns the fields and nests them by 2 spaces. -pformatWithConstructor :: Int -> Doc ann -> [Doc ann] -> Doc ann -pformatWithConstructor n c l = - group $ condEnclose (n > 10) "(" ")" $ align $ nest 2 $ vsep (c : l) - --- | Pretty print a list of fields with a constructor without alignment. -pformatWithConstructorNoAlign :: Int -> Doc ann -> [Doc ann] -> Doc ann -pformatWithConstructorNoAlign n c l = - group $ condEnclose (n > 10) "(" ")" $ nest 2 $ vsep (c : l) - --- | Pretty print a value using 'showsPrec'. -viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann -viaShowsPrec f n a = pretty (f n a "") - --- | Generic 'PPrint' class. -class GPPrint arity f where - gpformatPrec :: PPrintArgs arity a ann -> PPrintType -> Int -> f a -> Doc ann - gpformatList :: (HasCallStack) => PPrintArgs arity a ann -> [f a] -> Doc ann - gpformatList = error "generic format (gpformatList): unnecessary case" - gisNullary :: (HasCallStack) => PPrintArgs arity a ann -> f a -> Bool - gisNullary = error "generic format (isNullary): unnecessary case" - -instance GPPrint arity V1 where - gpformatPrec _ _ _ x = case x of {} - -instance GPPrint arity U1 where - gpformatPrec _ _ _ U1 = "" - gisNullary _ _ = True - -instance (PPrint c) => GPPrint arity (K1 i c) where - gpformatPrec _ _ n (K1 a) = pformatPrec n a - gisNullary _ _ = False - -instance (GPPrint arity a, Constructor c) => GPPrint arity (C1 c a) where - gpformatPrec arg _ n c@(M1 x) = - case t of - Tup -> - prettyBraces t (gpformatPrec arg t 0 x) - Inf _ m -> - group $ condEnclose (n > m) "(" ")" $ gpformatPrec arg t m x - _ -> - if gisNullary arg x - then pformat (conName c) - else - pformatWithConstructorNoAlign - n - (pformat (conName c)) - [prettyBraces t (gpformatPrec arg t 11 x)] - where - prettyBraces :: PPrintType -> Doc ann -> Doc ann - prettyBraces Rec = groupedEnclose "{" "}" - prettyBraces Tup = groupedEnclose "(" ")" - prettyBraces Pref = id - prettyBraces (Inf _ _) = id - fixity = conFixity c - t - | conIsRecord c = Rec - | conIsTuple c = Tup - | otherwise = case fixity of - Prefix -> Pref - Infix _ i -> Inf (conName c) i - conIsTuple :: C1 c f p -> Bool - conIsTuple y = tupleName (conName y) - where - tupleName ('(' : ',' : _) = True - tupleName _ = False - -instance (Selector s, GPPrint arity a) => GPPrint arity (S1 s a) where - gpformatPrec arg t n s@(M1 x) - | selName s == "" = - case t of - Pref -> gpformatPrec arg t (n + 1) x - _ -> gpformatPrec arg t (n + 1) x - | otherwise = - group $ - align $ - nest 2 $ - vsep [pretty (selName s) <+> "=", gpformatPrec arg t 0 x] - gisNullary _ _ = False - -instance (GPPrint arity a) => GPPrint arity (D1 d a) where - gpformatPrec arg _ n (M1 x) = gpformatPrec arg Pref n x - gpformatList arg = align . prettyPrintList . fmap (gpformatPrec arg Pref 0) - -instance (GPPrint arity a, GPPrint arity b) => GPPrint arity (a :+: b) where - gpformatPrec arg t n (L1 x) = gpformatPrec arg t n x - gpformatPrec arg t n (R1 x) = gpformatPrec arg t n x - -instance (GPPrint arity a, GPPrint arity b) => GPPrint arity (a :*: b) where - gpformatPrec arg t@Rec n (a :*: b) = - align $ - vcat - [ gpformatPrec arg t n a <> "," <> flatAlt "" " ", - gpformatPrec arg t n b - ] - gpformatPrec arg t@(Inf s _) n (a :*: b) = - nest 2 $ - vsep - [ align $ gpformatPrec arg t n a, - pretty s <+> gpformatPrec arg t n b - ] - gpformatPrec arg t@Tup _ (a :*: b) = - vcat - [ gpformatPrec arg t 0 a <> "," <> flatAlt "" " ", - gpformatPrec arg t 0 b - ] - gpformatPrec arg t@Pref n (a :*: b) = - vsep - [ gpformatPrec arg t (n + 1) a, - gpformatPrec arg t (n + 1) b - ] - gisNullary _ _ = False - -instance GPPrint Arity1 Par1 where - gpformatPrec (PPrintArgs1 f _) _ n (Par1 a) = f n a - gpformatList (PPrintArgs1 _ g) l = g $ unPar1 <$> l - -instance (PPrint1 f) => GPPrint Arity1 (Rec1 f) where - gpformatPrec (PPrintArgs1 f g) _ n (Rec1 x) = liftPFormatPrec f g n x - gpformatList (PPrintArgs1 f g) l = liftPFormatList f g $ unRec1 <$> l - -instance - (PPrint1 f, GPPrint Arity1 g) => - GPPrint Arity1 (f :.: g) - where - gpformatPrec arg t n (Comp1 x) = - liftPFormatPrec (gpformatPrec arg t) (gpformatList arg) n x - gpformatList arg l = - liftPFormatList (gpformatPrec arg Pref) (gpformatList arg) $ unComp1 <$> l - --- | Generic 'pformatPrec' function. -genericPFormatPrec :: - (Generic a, GPPrint Arity0 (Rep a)) => - Int -> - a -> - Doc ann -genericPFormatPrec n = gpformatPrec PPrintArgs0 Pref n . from -{-# INLINE genericPFormatPrec #-} - --- | Generic 'pformatList' function. -genericPFormatList :: - (Generic a, GPPrint Arity0 (Rep a)) => - [a] -> - Doc ann -genericPFormatList = gpformatList PPrintArgs0 . fmap from -{-# INLINE genericPFormatList #-} - --- | Generic 'liftPFormatPrec' function. -genericLiftPFormatPrec :: - (Generic1 f, GPPrint Arity1 (Rep1 f)) => - (Int -> a -> Doc ann) -> - ([a] -> Doc ann) -> - Int -> - f a -> - Doc ann -genericLiftPFormatPrec p l n = gpformatPrec (PPrintArgs1 p l) Pref n . from1 -{-# INLINE genericLiftPFormatPrec #-} - --- | Generic 'liftPFormatList' function. -genericLiftPFormatList :: - (Generic1 f, GPPrint Arity1 (Rep1 f)) => - (Int -> a -> Doc ann) -> - ([a] -> Doc ann) -> - [f a] -> - Doc ann -genericLiftPFormatList p l = gpformatList (PPrintArgs1 p l) . fmap from1 -{-# INLINE genericLiftPFormatList #-} - -instance - (Generic a, GPPrint Arity0 (Rep a)) => - PPrint (Default a) - where - pformatPrec n = genericPFormatPrec n . unDefault - pformatList = genericPFormatList . fmap unDefault - -instance - (Generic1 f, GPPrint Arity1 (Rep1 f), PPrint a) => - PPrint (Default1 f a) - where - pformatPrec = pformatPrec1 - pformatList = pformatList1 - -instance - (Generic1 f, GPPrint Arity1 (Rep1 f)) => - PPrint1 (Default1 f) - where - liftPFormatPrec p l n = genericLiftPFormatPrec p l n . unDefault1 - liftPFormatList p l = genericLiftPFormatList p l . fmap unDefault1 - -#define FORMAT_SIMPLE(type) \ -instance PPrint type where pformatPrec = viaShowsPrec showsPrec - -#if 1 -FORMAT_SIMPLE(Bool) -FORMAT_SIMPLE(Integer) -FORMAT_SIMPLE(Int) -FORMAT_SIMPLE(Int8) -FORMAT_SIMPLE(Int16) -FORMAT_SIMPLE(Int32) -FORMAT_SIMPLE(Int64) -FORMAT_SIMPLE(Word) -FORMAT_SIMPLE(Word8) -FORMAT_SIMPLE(Word16) -FORMAT_SIMPLE(Word32) -FORMAT_SIMPLE(Word64) -FORMAT_SIMPLE(Float) -FORMAT_SIMPLE(Double) -FORMAT_SIMPLE(FPRoundingMode) -FORMAT_SIMPLE(Monoid.All) -FORMAT_SIMPLE(Monoid.Any) -FORMAT_SIMPLE(Ordering) -FORMAT_SIMPLE(AlgReal) -#endif - -instance (PPrint a) => PPrint (Ratio a) where - pformatPrec p r = - condEnclose (p > ratioPrec) "(" ")" $ - pformatPrec ratioPrec1 (numerator r) - <> "%" - <> pformatPrec ratioPrec1 (denominator r) - -instance PPrint B.ByteString where - pformat = pretty . C.unpack - -instance PPrint T.Text where - pformat = pretty - -instance (KnownNat n, 1 <= n) => PPrint (IntN n) where - pformat = viaShow - -instance (KnownNat n, 1 <= n) => PPrint (WordN n) where - pformat = viaShow - -instance (ValidFP eb sb) => PPrint (FP eb sb) where - pformat = viaShow - -instance (Show a, Show b) => PPrint (a =-> b) where - pformat = viaShow - -instance PPrint (a --> b) where - pformat = viaShow - --- Prettyprint -#define FORMAT_SYM_SIMPLE(symtype) \ -instance PPrint symtype where \ - pformat (symtype t) = prettyPrintTerm t - -#define FORMAT_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => PPrint (symtype n) where \ - pformat (symtype t) = prettyPrintTerm t - -#define FORMAT_SYM_FUN(op, cons) \ -instance PPrint (sa op sb) where \ - pformat (cons t) = prettyPrintTerm t - -#if 1 -FORMAT_SYM_SIMPLE(SymBool) -FORMAT_SYM_SIMPLE(SymInteger) -FORMAT_SYM_SIMPLE(SymFPRoundingMode) -FORMAT_SYM_SIMPLE(SymAlgReal) -FORMAT_SYM_BV(SymIntN) -FORMAT_SYM_BV(SymWordN) -FORMAT_SYM_FUN(=~>, SymTabularFun) -FORMAT_SYM_FUN(-~>, SymGeneralFun) -#endif - -instance (ValidFP eb sb) => PPrint (SymFP eb sb) where - pformat (SymFP t) = prettyPrintTerm t - --- Instance -deriveBuiltins - (ViaDefault ''PPrint) - [''PPrint] - [ ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''PPrint1) - [''PPrint, ''PPrint1] - [ ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- Identity -instance (PPrint a) => PPrint (Identity a) where - pformatPrec = pformatPrec1 - -instance PPrint1 Identity where - liftPFormatPrec f _ n (Identity a) = f n a - --- MaybeT -instance - (PPrint1 m, PPrint a) => - PPrint (MaybeT m a) - where - pformatPrec = pformatPrec1 - -instance - (PPrint1 m) => - PPrint1 (MaybeT m) - where - liftPFormatPrec f l n (MaybeT a) = - pformatWithConstructor - n - "MaybeT" - [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] - --- ExceptT -instance - (PPrint1 m, PPrint e, PPrint a) => - PPrint (ExceptT e m a) - where - pformatPrec = pformatPrec1 - -instance - (PPrint1 m, PPrint e) => - PPrint1 (ExceptT e m) - where - liftPFormatPrec f l n (ExceptT a) = - pformatWithConstructor - n - "ExceptT" - [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] - --- WriterT -instance - (PPrint1 m, PPrint a, PPrint w) => - PPrint (WriterLazy.WriterT w m a) - where - pformatPrec = pformatPrec1 - -instance - (PPrint1 m, PPrint w) => - PPrint1 (WriterLazy.WriterT w m) - where - liftPFormatPrec f l n (WriterLazy.WriterT a) = - pformatWithConstructor - n - "WriterT" - [ liftPFormatPrec - (liftPFormatPrec2 f l pformatPrec pformatList) - (liftPFormatList2 f l pformatPrec pformatList) - 11 - a - ] - -instance - (PPrint1 m, PPrint a, PPrint w) => - PPrint (WriterStrict.WriterT w m a) - where - pformatPrec = pformatPrec1 - -instance - (PPrint1 m, PPrint w) => - PPrint1 (WriterStrict.WriterT w m) - where - liftPFormatPrec f l n (WriterStrict.WriterT a) = - pformatWithConstructor - n - "WriterT" - [ liftPFormatPrec - (liftPFormatPrec2 f l pformatPrec pformatList) - (liftPFormatList2 f l pformatPrec pformatList) - 11 - a - ] - --- IdentityT -instance (PPrint1 m, PPrint a) => PPrint (IdentityT m a) where - pformatPrec = pformatPrec1 - -instance (PPrint1 m) => PPrint1 (IdentityT m) where - liftPFormatPrec f l n (IdentityT a) = - pformatWithConstructor n "IdentityT" [liftPFormatPrec f l 11 a] - --- Product -deriving via - (Default (Product l r a)) - instance - (PPrint (l a), PPrint (r a)) => PPrint (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (PPrint1 l, PPrint1 r) => PPrint1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (PPrint (l a), PPrint (r a)) => PPrint (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (PPrint1 l, PPrint1 r) => PPrint1 (Sum l r) - --- Compose -instance (PPrint (f (g a))) => PPrint (Compose f g a) where - pformatPrec n (Compose a) = - pformatWithConstructor n "Compose" [pformatPrec 11 a] - -instance (PPrint1 f, PPrint1 g) => PPrint1 (Compose f g) where - liftPFormatPrec f l n (Compose a) = - pformatWithConstructor - n - "Compose" - [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] - --- Const -deriving via (Default (Const a b)) instance (PPrint a) => PPrint (Const a b) - -deriving via (Default1 (Const a)) instance (PPrint a) => PPrint1 (Const a) - --- Alt -deriving via (Default (Alt f a)) instance (PPrint (f a)) => PPrint (Alt f a) - -deriving via (Default1 (Alt f)) instance (PPrint1 f) => PPrint1 (Alt f) - --- Ap -deriving via (Default (Ap f a)) instance (PPrint (f a)) => PPrint (Ap f a) - -deriving via (Default1 (Ap f)) instance (PPrint1 f) => PPrint1 (Ap f) - --- Generic -deriving via (Default (U1 p)) instance PPrint (U1 p) - -deriving via (Default (V1 p)) instance PPrint (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (PPrint c) => PPrint (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (PPrint (f p)) => PPrint (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (PPrint (f p), PPrint (g p)) => PPrint ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (PPrint (f p), PPrint (g p)) => PPrint ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (PPrint p) => PPrint (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (PPrint (f p)) => PPrint (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (PPrint (f (g p))) => PPrint ((f :.: g) p) - --- PPrint2 -instance PPrint2 Either where - liftPFormatPrec2 fe _ _ _ n (Left e) = - pformatWithConstructor n "Left" [fe 11 e] - liftPFormatPrec2 _ _ fa _ n (Right a) = - pformatWithConstructor n "Right" [fa 11 a] - -instance PPrint2 (,) where - liftPFormatPrec2 fa _ fb _ _ (a, b) = - prettyPrintTuple [fa 0 a, fb 0 b] - -instance (PPrint a) => PPrint2 ((,,) a) where - liftPFormatPrec2 fb _ fc _ _ (a, b, c) = - prettyPrintTuple [pformat a, fb 0 b, fc 0 c] - -instance (PPrint a, PPrint b) => PPrint2 ((,,,) a b) where - liftPFormatPrec2 fc _ fd _ _ (a, b, c, d) = - prettyPrintTuple [pformat a, pformat b, fc 0 c, fd 0 d] - -instance (PPrint a) => PPrint (HS.HashSet a) where - pformatPrec = pformatPrec1 - -instance PPrint1 HS.HashSet where - liftPFormatPrec p l n s = - pformatWithConstructor n "HashSet" [liftPFormatPrec p l 11 $ HS.toList s] - -instance (PPrint k, PPrint v) => PPrint (HM.HashMap k v) where - pformatPrec = pformatPrec1 - -instance (PPrint k) => PPrint1 (HM.HashMap k) where - liftPFormatPrec = liftPFormatPrec2 pformatPrec pformatList - -instance PPrint2 HM.HashMap where - liftPFormatPrec2 pk lk pv lv n s = - pformatWithConstructor - n - "HashMap" - [ liftPFormatPrec - (liftPFormatPrec2 pk lk pv lv) - (liftPFormatList2 pk lk pv lv) - 11 - $ HM.toList s - ] - -instance PPrint Identifier where - pformat = viaShow - -instance PPrint Symbol where - pformat = viaShow - -instance PPrint (TypedSymbol knd t) where - pformat = viaShow - -instance PPrint (SomeTypedSymbol knd) where - pformat = viaShow - -instance PPrint ModelValue where - pformat = viaShow - -instance PPrint Model where - pformatPrec n (Model m) = - pformatWithConstructor n "Model" [bodyFormatted] - where - pformatSymbolWithoutType :: SomeTypedSymbol knd -> Doc ann - pformatSymbolWithoutType (SomeTypedSymbol s) = pformat $ unTypedSymbol s - pformatPair :: (SomeTypedSymbol knd, ModelValue) -> Doc ann - pformatPair (s, v) = pformatSymbolWithoutType s <> " -> " <> pformat v - bodyFormatted = pformatListLike "{" "}" $ pformatPair <$> HM.toList m - -instance PPrint (SymbolSet knd) where - pformatPrec n (SymbolSet s) = - pformatWithConstructor - n - "SymbolSet" - [pformatListLike "{" "}" $ pformat <$> HS.toList s] +import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint +import Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint () diff --git a/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs b/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs --- a/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs +++ b/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs @@ -27,6 +27,7 @@ onUnion2, onUnion3, onUnion4, + unionToCon, ) where @@ -37,14 +38,17 @@ import Grisette.Internal.Core.Data.Class.LogicalOp ( LogicalOp (symNot, (.&&)), ) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SimpleMergeable +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable ( SimpleMergeable, SymBranching, mrgIf, ) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.Core.Data.Class.TryMerge +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon (ToCon (toCon)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge ( mrgSingle, tryMerge, ) @@ -223,3 +227,21 @@ onUnion4 f ua ub uc ud = simpleMerge $ f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc <*> tryMerge ud + +-- | Convert a plain union to concrete values. +-- +-- >>> unionToCon (return 1 :: Union SymInteger) :: Maybe Integer +-- Just 1 +-- >>> unionToCon (mrgIf "a" (return 1) (return 2) :: Union SymInteger) :: Maybe Integer +-- Nothing +-- >>> unionToCon (return "a" :: Union SymInteger) :: Maybe Integer +-- Nothing +unionToCon :: (ToCon a b, PlainUnion u) => u a -> Maybe b +unionToCon u = + case (singleView u, ifView u) of + (Just x, _) -> toCon x + (_, Just (c, l, r)) -> do + cl <- toCon c + if cl then unionToCon l else unionToCon r + _ -> Nothing +{-# INLINE unionToCon #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SafeDiv.hs b/src/Grisette/Internal/Core/Data/Class/SafeDiv.hs --- a/src/Grisette/Internal/Core/Data/Class/SafeDiv.hs +++ b/src/Grisette/Internal/Core/Data/Class/SafeDiv.hs @@ -1,15 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.SafeDiv @@ -32,444 +21,5 @@ ) where -import Control.Exception (ArithException (DivideByZero, Overflow, Underflow)) -import Control.Monad.Except (MonadError (throwError)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==))) -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge, - mrgSingle, - tryMerge, - ) -import Grisette.Internal.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.Data.Functor (mrgFmap) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Control.Monad.Except --- >>> import Control.Exception - --- | Safe division handling with default values returned on exception. -class DivOr a where - -- | Safe 'div' with default value returned on exception. - -- - -- >>> divOr "d" "a" "b" :: SymInteger - -- (ite (= b 0) d (div a b)) - divOr :: a -> a -> a -> a - - -- | Safe 'mod' with default value returned on exception. - -- - -- >>> modOr "d" "a" "b" :: SymInteger - -- (ite (= b 0) d (mod a b)) - modOr :: a -> a -> a -> a - - -- | Safe 'divMod' with default value returned on exception. - -- - -- >>> divModOr ("d", "m") "a" "b" :: (SymInteger, SymInteger) - -- ((ite (= b 0) d (div a b)),(ite (= b 0) m (mod a b))) - divModOr :: (a, a) -> a -> a -> (a, a) - - -- | Safe 'quot' with default value returned on exception. - quotOr :: a -> a -> a -> a - - -- | Safe 'rem' with default value returned on exception. - remOr :: a -> a -> a -> a - - -- | Safe 'quotRem' with default value returned on exception. - quotRemOr :: (a, a) -> a -> a -> (a, a) - --- | Safe 'div' with 0 returned on exception. -divOrZero :: (DivOr a, Num a) => a -> a -> a -divOrZero l = divOr (l - l) l -{-# INLINE divOrZero #-} - --- | Safe 'mod' with dividend returned on exception. -modOrDividend :: (DivOr a, Num a) => a -> a -> a -modOrDividend l = modOr l l -{-# INLINE modOrDividend #-} - --- | Safe 'quot' with 0 returned on exception. -quotOrZero :: (DivOr a, Num a) => a -> a -> a -quotOrZero l = quotOr (l - l) l -{-# INLINE quotOrZero #-} - --- | Safe 'rem' with dividend returned on exception. -remOrDividend :: (DivOr a, Num a) => a -> a -> a -remOrDividend l = remOr l l -{-# INLINE remOrDividend #-} - --- | Safe 'divMod' with 0 returned on exception. -divModOrZeroDividend :: (DivOr a, Num a) => a -> a -> (a, a) -divModOrZeroDividend l = divModOr (l - l, l) l -{-# INLINE divModOrZeroDividend #-} - --- | Safe 'quotRem' with 0 returned on exception. -quotRemOrZeroDividend :: (DivOr a, Num a) => a -> a -> (a, a) -quotRemOrZeroDividend l = quotRemOr (l - l, l) l -{-# INLINE quotRemOrZeroDividend #-} - --- | Safe division with monadic error handling in multi-path --- execution. These procedures throw an exception when the --- divisor is zero. The result should be able to handle errors with --- `MonadError`. -class (MonadError e m, TryMerge m, Mergeable a, DivOr a) => SafeDiv e a m where - -- | Safe 'div' with monadic error handling in multi-path execution. - -- - -- >>> safeDiv "a" "b" :: ExceptT ArithException Union SymInteger - -- ExceptT {If (= b 0) (Left divide by zero) (Right (div a b))} - safeDiv :: a -> a -> m a - safeDiv l r = mrgFmap fst $ safeDivMod l r - {-# INLINE safeDiv #-} - - -- | Safe 'mod' with monadic error handling in multi-path execution. - -- - -- >>> safeMod "a" "b" :: ExceptT ArithException Union SymInteger - -- ExceptT {If (= b 0) (Left divide by zero) (Right (mod a b))} - safeMod :: a -> a -> m a - safeMod l r = mrgFmap snd $ safeDivMod l r - {-# INLINE safeMod #-} - - -- | Safe 'divMod' with monadic error handling in multi-path execution. - -- - -- >>> safeDivMod "a" "b" :: ExceptT ArithException Union (SymInteger, SymInteger) - -- ExceptT {If (= b 0) (Left divide by zero) (Right ((div a b),(mod a b)))} - safeDivMod :: a -> a -> m (a, a) - safeDivMod l r = do - d <- safeDiv l r - m <- safeMod l r - mrgSingle (d, m) - {-# INLINE safeDivMod #-} - - -- | Safe 'quot' with monadic error handling in multi-path execution. - safeQuot :: a -> a -> m a - safeQuot l r = mrgFmap fst $ safeQuotRem l r - {-# INLINE safeQuot #-} - - -- | Safe 'rem' with monadic error handling in multi-path execution. - safeRem :: a -> a -> m a - safeRem l r = mrgFmap snd $ safeQuotRem l r - {-# INLINE safeRem #-} - - -- | Safe 'quotRem' with monadic error handling in multi-path execution. - safeQuotRem :: a -> a -> m (a, a) - safeQuotRem l r = do - q <- safeQuot l r - m <- safeRem l r - mrgSingle (q, m) - {-# INLINE safeQuotRem #-} - - {-# MINIMAL - ((safeDiv, safeMod) | safeDivMod), - ((safeQuot, safeRem) | safeQuotRem) - #-} - -concreteDivOrHelper :: - (Integral a) => - (a -> a -> r) -> - r -> - a -> - a -> - r -concreteDivOrHelper f d l r - | r == 0 = d - | otherwise = f l r - -concreteSafeDivHelper :: - (MonadError ArithException m, TryMerge m, Integral a, Mergeable r) => - (a -> a -> r) -> - a -> - a -> - m r -concreteSafeDivHelper f l r - | r == 0 = tryMerge $ throwError DivideByZero - | otherwise = mrgSingle $ f l r - -concreteSignedBoundedDivOrHelper :: - ( Integral a, - Bounded a, - Mergeable r - ) => - (a -> a -> r) -> - r -> - a -> - a -> - r -concreteSignedBoundedDivOrHelper f d l r - | r == 0 = d - | l == minBound && r == -1 = d - | otherwise = f l r - -concreteSignedBoundedSafeDivHelper :: - ( MonadError ArithException m, - TryMerge m, - Integral a, - Bounded a, - Mergeable r - ) => - (a -> a -> r) -> - a -> - a -> - m r -concreteSignedBoundedSafeDivHelper f l r - | r == 0 = tryMerge $ throwError DivideByZero - | l == minBound && r == -1 = tryMerge $ throwError Overflow - | otherwise = mrgSingle $ f l r - -#define QUOTE() ' -#define QID(a) a -#define QRIGHT(a) QID(a)' - -#define QRIGHTT(a) QID(a)' t' -#define QRIGHTU(a) QID(a)' _' - -#define DIVISION_OR_CONCRETE(type) \ -instance DivOr type where \ - divOr = concreteDivOrHelper div; \ - modOr = concreteDivOrHelper mod; \ - divModOr = concreteDivOrHelper divMod; \ - quotOr = concreteDivOrHelper quot; \ - remOr = concreteDivOrHelper rem; \ - quotRemOr = concreteDivOrHelper quotRem - -#define SAFE_DIVISION_CONCRETE(type) \ -instance (MonadError ArithException m, TryMerge m) => \ - SafeDiv ArithException type m where \ - safeDiv = concreteSafeDivHelper div; \ - safeMod = concreteSafeDivHelper mod; \ - safeDivMod = concreteSafeDivHelper divMod; \ - safeQuot = concreteSafeDivHelper quot; \ - safeRem = concreteSafeDivHelper rem; \ - safeQuotRem = concreteSafeDivHelper quotRem - -#define DIVISION_OR_CONCRETE_SIGNED_BOUNDED(type) \ -instance DivOr type where \ - divOr = concreteSignedBoundedDivOrHelper div; \ - modOr = concreteDivOrHelper mod; \ - divModOr = concreteSignedBoundedDivOrHelper divMod; \ - quotOr = concreteSignedBoundedDivOrHelper quot; \ - remOr = concreteDivOrHelper rem; \ - quotRemOr = concreteSignedBoundedDivOrHelper quotRem - -#define SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(type) \ -instance (MonadError ArithException m, TryMerge m) => \ - SafeDiv ArithException type m where \ - safeDiv = concreteSignedBoundedSafeDivHelper div; \ - safeMod = concreteSafeDivHelper mod; \ - safeDivMod = concreteSignedBoundedSafeDivHelper divMod; \ - safeQuot = concreteSignedBoundedSafeDivHelper quot; \ - safeRem = concreteSafeDivHelper rem; \ - safeQuotRem = concreteSignedBoundedSafeDivHelper quotRem - -#if 1 -DIVISION_OR_CONCRETE(Integer) -SAFE_DIVISION_CONCRETE(Integer) -DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int8) -SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int8) -DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int16) -SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int16) -DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int32) -SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int32) -DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int64) -SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int64) -DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int) -SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int) -DIVISION_OR_CONCRETE(Word8) -SAFE_DIVISION_CONCRETE(Word8) -DIVISION_OR_CONCRETE(Word16) -SAFE_DIVISION_CONCRETE(Word16) -DIVISION_OR_CONCRETE(Word32) -SAFE_DIVISION_CONCRETE(Word32) -DIVISION_OR_CONCRETE(Word64) -SAFE_DIVISION_CONCRETE(Word64) -DIVISION_OR_CONCRETE(Word) -SAFE_DIVISION_CONCRETE(Word) - - -#endif - -instance (KnownNat n, 1 <= n) => DivOr (IntN n) where - divOr = concreteSignedBoundedDivOrHelper div - modOr = concreteDivOrHelper mod - divModOr = concreteSignedBoundedDivOrHelper divMod - quotOr = concreteSignedBoundedDivOrHelper quot - remOr = concreteDivOrHelper rem - quotRemOr = concreteSignedBoundedDivOrHelper quotRem - -instance - (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => - SafeDiv ArithException (IntN n) m - where - safeDiv = concreteSignedBoundedSafeDivHelper div - safeMod = concreteSafeDivHelper mod - safeDivMod = concreteSignedBoundedSafeDivHelper divMod - safeQuot = concreteSignedBoundedSafeDivHelper quot - safeRem = concreteSafeDivHelper rem - safeQuotRem = concreteSignedBoundedSafeDivHelper quotRem - -instance (KnownNat n, 1 <= n) => DivOr (WordN n) where - divOr = concreteDivOrHelper div - modOr = concreteDivOrHelper mod - divModOr = concreteDivOrHelper divMod - quotOr = concreteDivOrHelper quot - remOr = concreteDivOrHelper rem - quotRemOr = concreteDivOrHelper quotRem - -instance - (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => - SafeDiv ArithException (WordN n) m - where - safeDiv = concreteSafeDivHelper div - safeMod = concreteSafeDivHelper mod - safeDivMod = concreteSafeDivHelper divMod - safeQuot = concreteSafeDivHelper quot - safeRem = concreteSafeDivHelper rem - safeQuotRem = concreteSafeDivHelper quotRem - -#define DIVISION_OR_SYMBOLIC_FUNC(name, type, op) \ -name d (type l) rs@(type r) = \ - symIte (rs .== con 0) d (type $ op l r) - -#define DIVISION_OR_SYMBOLIC_FUNC2(name, type, op1, op2) \ -name (dd, dm) (type l) rs@(type r) = \ - (symIte (rs .== con 0) dd (type $ op1 l r), \ - symIte (rs .== con 0) dm (type $ op2 l r)) - -#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 DivOr SymInteger where - DIVISION_OR_SYMBOLIC_FUNC(divOr, SymInteger, pevalDivIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(modOr, SymInteger, pevalModIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(quotOr, SymInteger, pevalQuotIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(remOr, SymInteger, pevalRemIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC2(divModOr, SymInteger, pevalDivIntegralTerm, pevalModIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC2(quotRemOr, SymInteger, pevalQuotIntegralTerm, pevalRemIntegralTerm) -instance - (MonadUnion m, MonadError ArithException m) => - SafeDiv 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 DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, type, op) \ -name d ls@(type l) rs@(type r) = \ - symIte \ - (rs .== con 0) \ - d \ - (symIte (rs .== con (-1) .&& ls .== con minBound) \ - d \ - (type $ op l r)) \ - -#define DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, type, op1, op2) \ -name (dd, dr) ls@(type l) rs@(type r) = \ - (symIte \ - (rs .== con 0) \ - dd \ - (symIte (rs .== con (-1) .&& ls .== con minBound) \ - dd \ - (type $ op1 l r)), \ - symIte \ - (rs .== con 0) \ - dr \ - (symIte (rs .== con (-1) .&& ls .== con minBound) \ - dr \ - (type $ op2 l r))) \ - -#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 (KnownNat n, 1 <= n) => DivOr (SymIntN n) where - DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(divOr, SymIntN, pevalDivIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(modOr, SymIntN, pevalModIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(quotOr, SymIntN, pevalQuotIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(remOr, SymIntN, pevalRemIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(divModOr, SymIntN, pevalDivIntegralTerm, pevalModIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(quotRemOr, SymIntN, pevalQuotIntegralTerm, pevalRemIntegralTerm) -instance - (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => - SafeDiv 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 (KnownNat n, 1 <= n) => DivOr (SymWordN n) where - DIVISION_OR_SYMBOLIC_FUNC(divOr, SymWordN, pevalDivIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(modOr, SymWordN, pevalModIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(quotOr, SymWordN, pevalQuotIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC(remOr, SymWordN, pevalRemIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC2(divModOr, SymWordN, pevalDivIntegralTerm, pevalModIntegralTerm) - DIVISION_OR_SYMBOLIC_FUNC2(quotRemOr, SymWordN, pevalQuotIntegralTerm, pevalRemIntegralTerm) -instance - (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => - SafeDiv 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 +import Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv +import Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv () diff --git a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs --- a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs +++ b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs @@ -1,19 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.SimpleMergeable @@ -45,795 +30,5 @@ ) 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.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap, Endo (Endo)) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import GHC.Generics - ( Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - ) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving (Default (Default), Default1 (Default1)) -import Grisette.Internal.Core.Control.Exception (AssertionError) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.Core.Data.Class.Mergeable - ( GMergeable, - Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - Mergeable2 (liftRootStrategy2), - Mergeable3 (liftRootStrategy3), - MergingStrategy (SimpleStrategy), - ) -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge (tryMergeWithStrategy), - ) -import Grisette.Internal.SymPrim.FP (ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN, - SymWordN, - ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Control.Monad.Identity - --- | This class indicates that a type has a simple root merge strategy. --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... --- > deriving Generic --- > deriving (Mergeable, SimpleMergeable) via (Default X) -class (Mergeable a) => SimpleMergeable a where - -- | Performs if-then-else with the simple root merge strategy. - -- - -- >>> mrgIte "a" "b" "c" :: SymInteger - -- (ite a b c) - mrgIte :: SymBool -> a -> a -> a - --- | Lifting of the 'SimpleMergeable' class to unary type constructors. -class - (Mergeable1 u, forall a. (SimpleMergeable a) => (SimpleMergeable (u a))) => - SimpleMergeable1 u - where - -- | Lift 'mrgIte' through the type constructor. - -- - -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger - -- Identity (ite a b c) - liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a - --- | Lift the standard 'mrgIte' function through the type constructor. --- --- >>> mrgIte1 "a" (Identity "b") (Identity "c") :: Identity SymInteger --- Identity (ite a b c) -mrgIte1 :: - (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a -mrgIte1 = liftMrgIte mrgIte -{-# INLINE mrgIte1 #-} - --- | Lifting of the 'SimpleMergeable' class to binary type constructors. -class - (Mergeable2 u, forall a. (SimpleMergeable a) => SimpleMergeable1 (u a)) => - SimpleMergeable2 u - where - -- | Lift 'mrgIte' through the type constructor. - -- - -- >>> liftMrgIte2 mrgIte mrgIte "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) - -- ((ite a b d),(ite a c e)) - liftMrgIte2 :: - (SymBool -> a -> a -> a) -> - (SymBool -> b -> b -> b) -> - SymBool -> - u a b -> - u a b -> - u a b - --- | Lift the standard 'mrgIte' function through the type constructor. --- --- >>> mrgIte2 "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) --- ((ite a b d),(ite a c e)) -mrgIte2 :: - (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => - SymBool -> - u a b -> - u a b -> - u a b -mrgIte2 = liftMrgIte2 mrgIte mrgIte -{-# INLINE mrgIte2 #-} - --- | The arguments to the generic simple merging function. -data family SimpleMergeableArgs arity a :: Type - -data instance SimpleMergeableArgs Arity0 _ = SimpleMergeableArgs0 - -newtype instance SimpleMergeableArgs Arity1 a - = SimpleMergeableArgs1 (SymBool -> a -> a -> a) - --- | Generic 'SimpleMergeable' class. -class GSimpleMergeable arity f where - gmrgIte :: SimpleMergeableArgs arity a -> SymBool -> f a -> f a -> f a - -instance GSimpleMergeable arity V1 where - gmrgIte _ _ t _ = t - {-# INLINE gmrgIte #-} - -instance (GSimpleMergeable arity U1) where - gmrgIte _ _ t _ = t - {-# INLINE gmrgIte #-} - -instance - (GSimpleMergeable arity a, GSimpleMergeable arity b) => - (GSimpleMergeable arity (a :*: b)) - where - gmrgIte args cond (a1 :*: a2) (b1 :*: b2) = - gmrgIte args cond a1 b1 :*: gmrgIte args cond a2 b2 - {-# INLINE gmrgIte #-} - -instance (GSimpleMergeable arity a) => (GSimpleMergeable arity (M1 i c a)) where - gmrgIte args cond (M1 a) (M1 b) = M1 $ gmrgIte args cond a b - {-# INLINE gmrgIte #-} - -instance (SimpleMergeable c) => (GSimpleMergeable arity (K1 i c)) where - gmrgIte _ cond (K1 a) (K1 b) = K1 $ mrgIte cond a b - {-# INLINE gmrgIte #-} - -instance GSimpleMergeable Arity1 Par1 where - gmrgIte (SimpleMergeableArgs1 f) cond (Par1 l) (Par1 r) = Par1 $ f cond l r - {-# INLINE gmrgIte #-} - -instance (SimpleMergeable1 f) => GSimpleMergeable Arity1 (Rec1 f) where - gmrgIte (SimpleMergeableArgs1 f) cond (Rec1 l) (Rec1 r) = - Rec1 $ liftMrgIte f cond l r - {-# INLINE gmrgIte #-} - -instance - (SimpleMergeable1 f, GSimpleMergeable Arity1 g) => - GSimpleMergeable Arity1 (f :.: g) - where - gmrgIte targs cond (Comp1 l) (Comp1 r) = - Comp1 $ liftMrgIte (gmrgIte targs) cond l r - {-# INLINE gmrgIte #-} - -instance - (Generic a, GSimpleMergeable Arity0 (Rep a), GMergeable Arity0 (Rep a)) => - SimpleMergeable (Default a) - where - mrgIte cond (Default a) (Default b) = - Default $ genericMrgIte cond a b - {-# INLINE mrgIte #-} - --- | Generic 'mrgIte' function. -genericMrgIte :: - (Generic a, GSimpleMergeable Arity0 (Rep a)) => - SymBool -> - a -> - a -> - a -genericMrgIte cond a b = - to $ gmrgIte SimpleMergeableArgs0 cond (from a) (from b) -{-# INLINE genericMrgIte #-} - -instance - ( Generic1 f, - GSimpleMergeable Arity1 (Rep1 f), - GMergeable Arity1 (Rep1 f), - SimpleMergeable a - ) => - SimpleMergeable (Default1 f a) - where - mrgIte = mrgIte1 - {-# INLINE mrgIte #-} - -instance - (Generic1 f, GSimpleMergeable Arity1 (Rep1 f), GMergeable Arity1 (Rep1 f)) => - SimpleMergeable1 (Default1 f) - where - liftMrgIte f c (Default1 l) (Default1 r) = - Default1 $ genericLiftMrgIte f c l r - {-# INLINE liftMrgIte #-} - --- | Generic 'liftMrgIte' function. -genericLiftMrgIte :: - (Generic1 f, GSimpleMergeable Arity1 (Rep1 f)) => - (SymBool -> a -> a -> a) -> - SymBool -> - f a -> - f a -> - f a -genericLiftMrgIte f c l r = - to1 $ gmrgIte (SimpleMergeableArgs1 f) c (from1 l) (from1 r) -{-# INLINE genericLiftMrgIte #-} - --- | Special case of the 'Mergeable1' and 'SimpleMergeable1' class for type --- constructors that are 'SimpleMergeable' when applied to any 'Mergeable' --- types. --- --- This type class is used to generalize the 'mrgIf' function to other --- containers, for example, monad transformer transformed Unions. -class - ( SimpleMergeable1 u, - forall a. (Mergeable a) => SimpleMergeable (u a), - TryMerge u - ) => - SymBranching (u :: Type -> Type) - where - -- | Symbolic @if@ control flow with the result merged with some merge - -- strategy. - -- - -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (return "c") :: Union SymInteger - -- {(ite a b c)} - -- - -- __Note:__ Be careful to call this directly in your code. - -- The supplied merge strategy should be consistent with the type's root merge - -- strategy, or some internal invariants would be broken and the program can - -- crash. - -- - -- This function is to be called when the 'Mergeable' constraint can not be - -- resolved, e.g., the merge strategy for the contained type is given with - -- 'Mergeable1'. In other cases, 'mrgIf' is usually a better alternative. - mrgIfWithStrategy :: MergingStrategy a -> SymBool -> u a -> u a -> u a - - -- | Symbolic @if@ control flow with the result. - -- - -- This function does not need a merging strategy, and it will merge the - -- result only if any of the branches is merged. - mrgIfPropagatedStrategy :: SymBool -> u a -> u a -> u a - --- | Try to merge the container with a given merge strategy. -mergeWithStrategy :: (SymBranching m) => MergingStrategy a -> m a -> m a -mergeWithStrategy = tryMergeWithStrategy -{-# INLINE mergeWithStrategy #-} - --- | Try to merge the container with the root strategy. -merge :: (SymBranching m, Mergeable a) => m a -> m a -merge = mergeWithStrategy rootStrategy -{-# INLINE merge #-} - --- | Symbolic @if@ control flow with the result merged with the type's root --- merge strategy. --- --- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@. --- --- >>> mrgIf "a" (return "b") (return "c") :: Union SymInteger --- {(ite a b c)} -mrgIf :: (SymBranching u, Mergeable a) => SymBool -> u a -> u a -> u a -mrgIf = mrgIfWithStrategy rootStrategy -{-# INLINE mrgIf #-} - -deriveBuiltins - (ViaDefault ''SimpleMergeable) - [''SimpleMergeable] - [ ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''SimpleMergeable1) - [''SimpleMergeable, ''SimpleMergeable1] - [ ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Down - ] - -instance SimpleMergeable2 (,) where - liftMrgIte2 ma mb cond (a1, b1) (a2, b2) = (ma cond a1 a2, mb cond b1 b2) - {-# INLINE liftMrgIte2 #-} - -instance (SimpleMergeable a) => SimpleMergeable2 ((,,) a) where - liftMrgIte2 mb mc cond (a1, b1, c1) (a2, b2, c2) = - (mrgIte cond a1 a2, mb cond b1 b2, mc cond c1 c2) - {-# INLINE liftMrgIte2 #-} - -instance - (SimpleMergeable a, SimpleMergeable b) => - SimpleMergeable2 ((,,,) a b) - where - liftMrgIte2 mc md cond (a1, b1, c1, d1) (a2, b2, c2, d2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mc cond c1 c2, md cond d1 d2) - {-# INLINE liftMrgIte2 #-} - -instance (SimpleMergeable b) => SimpleMergeable (a -> b) where - mrgIte = mrgIte1 - {-# INLINE mrgIte #-} - -instance SimpleMergeable1 ((->) a) where - liftMrgIte ms cond t f v = ms cond (t v) (f v) - {-# INLINE liftMrgIte #-} - -instance SimpleMergeable2 (->) where - liftMrgIte2 _ ms cond t f v = ms cond (t v) (f v) - {-# INLINE liftMrgIte2 #-} - --- MaybeT -instance (SymBranching m, Mergeable a) => SimpleMergeable (MaybeT m a) where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance (SymBranching m) => SimpleMergeable1 (MaybeT m) where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance (SymBranching m) => SymBranching (MaybeT m) where - mrgIfWithStrategy strategy cond (MaybeT l) (MaybeT r) = - MaybeT $ mrgIfWithStrategy (liftRootStrategy strategy) cond l r - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (MaybeT l) (MaybeT r) = - MaybeT $ mrgIfPropagatedStrategy cond l r - {-# INLINE mrgIfPropagatedStrategy #-} - --- ExceptT -instance - (SymBranching m, Mergeable e, Mergeable a) => - SimpleMergeable (ExceptT e m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (SymBranching m, Mergeable e) => - SimpleMergeable1 (ExceptT e m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (SymBranching m, Mergeable e) => - SymBranching (ExceptT e m) - where - mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = - ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (ExceptT t) (ExceptT f) = - ExceptT $ mrgIfPropagatedStrategy cond t f - {-# INLINE mrgIfPropagatedStrategy #-} - --- StateT -instance - (Mergeable s, Mergeable a, SymBranching m) => - SimpleMergeable (StateLazy.StateT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, SymBranching m) => - SimpleMergeable1 (StateLazy.StateT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, SymBranching m) => - SymBranching (StateLazy.StateT s m) - where - mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) = - StateLazy.StateT $ \v -> - mrgIfWithStrategy - (liftRootStrategy2 s rootStrategy) - cond - (t v) - (f v) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (StateLazy.StateT t) (StateLazy.StateT f) = - StateLazy.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) - {-# INLINE mrgIfPropagatedStrategy #-} - -instance - (Mergeable s, Mergeable a, SymBranching m) => - SimpleMergeable (StateStrict.StateT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, SymBranching m) => - SimpleMergeable1 (StateStrict.StateT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, SymBranching m) => - SymBranching (StateStrict.StateT s m) - where - mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) = - StateStrict.StateT $ - \v -> - mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (StateStrict.StateT t) (StateStrict.StateT f) = - StateStrict.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) - {-# INLINE mrgIfPropagatedStrategy #-} - --- WriterT -instance - (Mergeable s, Mergeable a, SymBranching m, Monoid s) => - SimpleMergeable (WriterLazy.WriterT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, SymBranching m, Monoid s) => - SimpleMergeable1 (WriterLazy.WriterT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, SymBranching m, Monoid s) => - SymBranching (WriterLazy.WriterT s m) - where - mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = - WriterLazy.WriterT $ - mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = - WriterLazy.WriterT $ mrgIfPropagatedStrategy cond t f - {-# INLINE mrgIfPropagatedStrategy #-} - -instance - (Mergeable s, Mergeable a, SymBranching m, Monoid s) => - SimpleMergeable (WriterStrict.WriterT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, SymBranching m, Monoid s) => - SimpleMergeable1 (WriterStrict.WriterT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, SymBranching m, Monoid s) => - SymBranching (WriterStrict.WriterT s m) - where - mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = - WriterStrict.WriterT $ - mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy - cond - (WriterStrict.WriterT t) - (WriterStrict.WriterT f) = - WriterStrict.WriterT $ mrgIfPropagatedStrategy cond t f - {-# INLINE mrgIfPropagatedStrategy #-} - --- ReaderT -instance - (Mergeable a, SymBranching m) => - SimpleMergeable (ReaderT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (SymBranching m) => - SimpleMergeable1 (ReaderT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (SymBranching m) => - SymBranching (ReaderT s m) - where - mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) = - ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (ReaderT t) (ReaderT f) = - ReaderT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) - {-# INLINE mrgIfPropagatedStrategy #-} - --- IdentityT -instance - (SymBranching m, Mergeable a) => - SimpleMergeable (IdentityT m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance (SymBranching m) => SimpleMergeable1 (IdentityT m) where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance (SymBranching m) => SymBranching (IdentityT m) where - mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = - IdentityT $ mrgIfWithStrategy s cond l r - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (IdentityT l) (IdentityT r) = - IdentityT $ mrgIfPropagatedStrategy cond l r - {-# INLINE mrgIfPropagatedStrategy #-} - --- ContT -instance (SymBranching m, Mergeable r) => SimpleMergeable (ContT r m a) where - mrgIte cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) - {-# INLINE mrgIte #-} - -instance (SymBranching m, Mergeable r) => SimpleMergeable1 (ContT r m) where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance (SymBranching m, Mergeable r) => SymBranching (ContT r m) where - mrgIfWithStrategy _ cond (ContT l) (ContT r) = - ContT $ \c -> mrgIf cond (l c) (r c) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (ContT l) (ContT r) = - ContT $ \c -> mrgIfPropagatedStrategy cond (l c) (r c) - {-# INLINE mrgIfPropagatedStrategy #-} - --- RWST -instance - (Mergeable s, Mergeable w, Monoid w, Mergeable a, SymBranching m) => - SimpleMergeable (RWSLazy.RWST r w s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, SymBranching m) => - SimpleMergeable1 (RWSLazy.RWST r w s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, SymBranching m) => - SymBranching (RWSLazy.RWST r w s m) - where - mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) = - RWSLazy.RWST $ \r s -> - mrgIfWithStrategy - (liftRootStrategy3 ms rootStrategy rootStrategy) - cond - (t r s) - (f r s) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (RWSLazy.RWST t) (RWSLazy.RWST f) = - RWSLazy.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) - {-# INLINE mrgIfPropagatedStrategy #-} - -instance - (Mergeable s, Mergeable w, Monoid w, Mergeable a, SymBranching m) => - SimpleMergeable (RWSStrict.RWST r w s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, SymBranching m) => - SimpleMergeable1 (RWSStrict.RWST r w s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, SymBranching m) => - SymBranching (RWSStrict.RWST r w s m) - where - mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) = - RWSStrict.RWST $ \r s -> - mrgIfWithStrategy - (liftRootStrategy3 ms rootStrategy rootStrategy) - cond - (t r s) - (f r s) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (RWSStrict.RWST t) (RWSStrict.RWST f) = - RWSStrict.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) - {-# INLINE mrgIfPropagatedStrategy #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (SimpleMergeable (l a), SimpleMergeable (r a)) => - SimpleMergeable (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (SimpleMergeable1 l, SimpleMergeable1 r) => SimpleMergeable1 (Product l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (SimpleMergeable (f (g a))) => - SimpleMergeable (Compose f g a) - -instance - (SimpleMergeable1 f, SimpleMergeable1 g) => - SimpleMergeable1 (Compose f g) - where - liftMrgIte m cond (Compose l) (Compose r) = - Compose $ liftMrgIte (liftMrgIte m) cond l r - --- Const -deriving via - (Default (Const a b)) - instance - (SimpleMergeable a) => SimpleMergeable (Const a b) - -deriving via - (Default1 (Const a)) - instance - (SimpleMergeable a) => SimpleMergeable1 (Const a) - --- Alt -deriving via - (Default (Alt f a)) - instance - (SimpleMergeable (f a)) => SimpleMergeable (Alt f a) - -deriving via - (Default1 (Alt f)) - instance - (SimpleMergeable1 f) => SimpleMergeable1 (Alt f) - --- Ap -deriving via - (Default (Ap f a)) - instance - (SimpleMergeable (f a)) => SimpleMergeable (Ap f a) - -deriving via - (Default1 (Ap f)) - instance - (SimpleMergeable1 f) => SimpleMergeable1 (Ap f) - --- Endo -instance (SimpleMergeable a) => SimpleMergeable (Endo a) where - mrgIte = mrgIte1 - {-# INLINE mrgIte #-} - -instance SimpleMergeable1 Endo where - liftMrgIte m cond (Endo l) (Endo r) = Endo $ liftMrgIte m cond l r - {-# INLINE liftMrgIte #-} - --- Generic -deriving via (Default (U1 p)) instance SimpleMergeable (U1 p) - -deriving via (Default (V1 p)) instance SimpleMergeable (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (SimpleMergeable c) => SimpleMergeable (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (SimpleMergeable (f p)) => SimpleMergeable (M1 i c f p) - -deriving via - (Default ((f :*: g) p)) - instance - (SimpleMergeable (f p), SimpleMergeable (g p)) => - SimpleMergeable ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (SimpleMergeable p) => SimpleMergeable (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (SimpleMergeable (f p)) => SimpleMergeable (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (SimpleMergeable (f (g p))) => SimpleMergeable ((f :.: g) p) - -#define SIMPLE_MERGEABLE_SIMPLE(symtype) \ -instance SimpleMergeable symtype where \ - mrgIte = 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 SimpleMergeable (op sa sb) where \ - mrgIte = symIte; \ - {-# INLINE mrgIte #-} - -#if 1 -SIMPLE_MERGEABLE_SIMPLE(SymBool) -SIMPLE_MERGEABLE_SIMPLE(SymInteger) -SIMPLE_MERGEABLE_SIMPLE(SymFPRoundingMode) -SIMPLE_MERGEABLE_SIMPLE(SymAlgReal) -SIMPLE_MERGEABLE_BV(SymIntN) -SIMPLE_MERGEABLE_BV(SymWordN) -SIMPLE_MERGEABLE_FUN((=->), (=~>)) -SIMPLE_MERGEABLE_FUN((-->), (-~>)) -#endif - -instance SimpleMergeable (a --> b) where - mrgIte = symIte - {-# INLINE mrgIte #-} - -instance (ValidFP eb sb) => SimpleMergeable (SymFP eb sb) where - mrgIte = symIte - {-# INLINE mrgIte #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable +import Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable () diff --git a/src/Grisette/Internal/Core/Data/Class/Solver.hs b/src/Grisette/Internal/Core/Data/Class/Solver.hs --- a/src/Grisette/Internal/Core/Data/Class/Solver.hs +++ b/src/Grisette/Internal/Core/Data/Class/Solver.hs @@ -1,20 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.Solver @@ -54,376 +38,5 @@ ) where -import Control.DeepSeq (NFData) -import Control.Exception (mask, onException) -import Control.Monad.Except (ExceptT, runExceptT) -import qualified Data.Binary as Binary -import Data.Bytes.Serial (Serial (deserialize, serialize)) -import qualified Data.HashSet as S -import Data.Hashable (Hashable) -import Data.Maybe (fromJust) -import qualified Data.Serialize as Cereal -import qualified Data.Text as T -import GHC.Generics (Generic) -import Generics.Deriving (Default (Default)) -import Grisette.Internal.Core.Data.Class.ExtractSym - ( ExtractSym (extractSym), - ) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) -import Grisette.Internal.Core.Data.Class.PPrint (PPrint) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( PlainUnion, - simpleMerge, - ) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.SymPrim.Prim.Model - ( AnySymbolSet, - Model, - SymbolSet (unSymbolSet), - equation, - ) -import Grisette.Internal.SymPrim.Prim.Term - ( SomeTypedSymbol (SomeTypedSymbol), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Language.Haskell.TH.Syntax (Lift) - -data SolveInternal = SolveInternal - deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData) - --- $setup --- >>> import Grisette --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Grisette.Backend - --- | The current failures that can be returned by the solver. -data SolvingFailure - = -- | Unsatisfiable: No model is available. - Unsat - | -- | Unknown: The solver cannot determine whether the formula is - -- satisfiable. - Unk - | -- | The solver has reached the maximum number of models to return. - ResultNumLimitReached - | -- | The solver has encountered an error. - SolvingError T.Text - | -- | The solver has been terminated. - Terminated - deriving (Show, Eq, Generic, Lift) - deriving anyclass (NFData, Hashable, Serial) - deriving (PPrint) via (Default SolvingFailure) - -instance Cereal.Serialize SolvingFailure where - put = serialize - get = deserialize - -instance Binary.Binary SolvingFailure where - put = serialize - get = deserialize - --- | A monadic solver interface. --- --- This interface abstract the monadic interface of a solver. All the operations --- performed in the monad are using a single solver instance. The solver --- instance is management by the monad's @run@ function. -class (Monad m) => MonadicSolver m where - monadicSolverPush :: Int -> m () - monadicSolverPop :: Int -> m () - monadicSolverResetAssertions :: m () - monadicSolverAssert :: SymBool -> m () - monadicSolverCheckSat :: m (Either SolvingFailure Model) - --- | Solve a single formula with a monadic solver. Find an assignment to it to --- make it true. -monadicSolverSolve :: - (MonadicSolver m) => SymBool -> m (Either SolvingFailure Model) -monadicSolverSolve formula = do - monadicSolverAssert formula - monadicSolverCheckSat - --- | The commands that can be sent to a solver. -data SolverCommand - = SolverAssert !SymBool - | SolverCheckSat - | SolverPush Int - | SolverPop Int - | SolverResetAssertions - | SolverTerminate - --- | A class that abstracts the solver interface. -class Solver handle where - -- | Run a solver command. - solverRunCommand :: - (handle -> IO (Either SolvingFailure a)) -> - handle -> - SolverCommand -> - IO (Either SolvingFailure a) - - -- | Assert a formula. - solverAssert :: handle -> SymBool -> IO (Either SolvingFailure ()) - solverAssert handle formula = - solverRunCommand (const $ return $ Right ()) handle $ SolverAssert formula - - -- | Solve a formula. - solverCheckSat :: handle -> IO (Either SolvingFailure Model) - - -- | Push @n@ levels. - solverPush :: handle -> Int -> IO (Either SolvingFailure ()) - solverPush handle n = - solverRunCommand (const $ return $ Right ()) handle $ SolverPush n - - -- | Pop @n@ levels. - solverPop :: handle -> Int -> IO (Either SolvingFailure ()) - solverPop handle n = - solverRunCommand (const $ return $ Right ()) handle $ SolverPop n - - -- | Reset all assertions in the solver. - -- - -- The solver keeps all the assertions used in the previous commands: - -- - -- >>> solver <- newSolver z3 - -- >>> solverSolve solver "a" - -- Right (Model {a -> true :: Bool}) - -- >>> solverSolve solver $ symNot "a" - -- Left Unsat - -- - -- You can clear the assertions using @solverResetAssertions@: - -- - -- >>> solverResetAssertions solver - -- Right () - -- >>> solverSolve solver $ symNot "a" - -- Right (Model {a -> false :: Bool}) - solverResetAssertions :: handle -> IO (Either SolvingFailure ()) - solverResetAssertions handle = - solverRunCommand (const $ return $ Right ()) handle SolverResetAssertions - - -- | Terminate the solver, wait until the last command is finished. - solverTerminate :: handle -> IO () - - -- | Force terminate the solver, do not wait for the last command to finish. - solverForceTerminate :: handle -> IO () - --- | Solve a single formula. Find an assignment to it to make it true. -solverSolve :: - (Solver handle) => handle -> SymBool -> IO (Either SolvingFailure Model) -solverSolve solver formula = do - res <- solverAssert solver formula - case res of - Left err -> return $ Left err - Right _ -> solverCheckSat solver - --- | Solve a single formula while returning multiple models to make it true. --- The maximum number of desired models are given. -solverSolveMulti :: - (Solver handle) => - -- | solver handle - handle -> - -- | maximum number of models to return - Int -> - -- | formula to solve, the solver will try to make it true - SymBool -> - IO ([Model], SolvingFailure) -solverSolveMulti solver numOfModelRequested formula = do - firstModel <- solverSolve solver formula - case firstModel of - Left err -> return ([], err) - Right model -> do - (models, err) <- go solver model numOfModelRequested - return (model : models, err) - where - allSymbols = extractSym formula :: AnySymbolSet - go solver prevModel n - | n <= 1 = return ([], ResultNumLimitReached) - | otherwise = do - let newFormula = - S.foldl' - ( \acc (SomeTypedSymbol v) -> - acc - .|| (symNot (SymBool $ fromJust $ equation v prevModel)) - ) - (con False) - (unSymbolSet allSymbols) - res <- solverSolve solver newFormula - case res of - Left err -> return ([], err) - Right model -> do - (models, err) <- go solver model (n - 1) - return (model : models, err) - --- | --- Solver procedure for programs with error handling. -solverSolveExcept :: - ( UnionWithExcept t u e v, - PlainUnion u, - Functor u, - Solver handle - ) => - -- | solver handle - handle -> - -- | mapping the results to symbolic boolean formulas, the solver would try to - -- find a model to make the formula true - (Either e v -> SymBool) -> - -- | the program to be solved, should be a union of exception and values - t -> - IO (Either SolvingFailure Model) -solverSolveExcept solver f v = - solverSolve solver (simpleMerge $ f <$> extractUnionExcept v) - --- | --- Solver procedure for programs with error handling. Would return multiple --- models if possible. -solverSolveMultiExcept :: - ( UnionWithExcept t u e v, - PlainUnion u, - Functor u, - Solver handle - ) => - -- | solver configuration - handle -> - -- | maximum number of models to return - Int -> - -- | mapping the results to symbolic boolean formulas, the solver would try to - -- find a model to make the formula true - (Either e v -> SymBool) -> - -- | the program to be solved, should be a union of exception and values - t -> - IO ([Model], SolvingFailure) -solverSolveMultiExcept handle n f v = - solverSolveMulti handle n (simpleMerge $ f <$> extractUnionExcept v) - --- | A class that abstracts the creation of a solver instance based on a --- configuration. --- --- The solver instance will need to be terminated by the user, with the solver --- interface. -class - (Solver handle) => - ConfigurableSolver config handle - | config -> handle - where - newSolver :: config -> IO handle - --- | Start a solver, run a computation with the solver, and terminate the --- solver after the computation finishes. --- --- When an exception happens, this will forcibly terminate the solver. --- --- Note: if Grisette is compiled with sbv < 10.10, the solver likely won't be --- really terminated until it has finished the last action, and this will --- result in long-running or zombie solver instances. --- --- This was due to a bug in sbv, which is fixed in --- https://github.com/LeventErkok/sbv/pull/695. -withSolver :: - (ConfigurableSolver config handle) => - config -> - (handle -> IO a) -> - IO a -withSolver config action = - mask $ \restore -> do - handle <- newSolver config - r <- restore (action handle) `onException` solverForceTerminate handle - solverTerminate handle - return r - --- | Solve a single formula. Find an assignment to it to make it true. --- --- >>> solve z3 ("a" .&& ("b" :: SymInteger) .== 1) --- Right (Model {a -> true :: Bool, b -> 1 :: Integer}) --- >>> solve z3 ("a" .&& symNot "a") --- Left Unsat -solve :: - (ConfigurableSolver config handle) => - -- | solver configuration - config -> - -- | formula to solve, the solver will try to make it true - SymBool -> - IO (Either SolvingFailure Model) -solve config formula = withSolver config (`solverSolve` formula) - --- | Solve a single formula while returning multiple models to make it true. --- The maximum number of desired models are given. --- --- > >>> solveMulti z3 4 ("a" .|| "b") --- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] -solveMulti :: - (ConfigurableSolver config handle) => - -- | solver configuration - config -> - -- | maximum number of models to return - Int -> - -- | formula to solve, the solver will try to make it true - SymBool -> - IO ([Model], SolvingFailure) -solveMulti config numOfModelRequested formula = - withSolver config $ - \solver -> solverSolveMulti solver numOfModelRequested formula - --- | A class that abstracts the union-like structures that contains exceptions. -class UnionWithExcept t u e v | t -> u e v where - -- | Extract a union of exceptions and values from the structure. - extractUnionExcept :: t -> u (Either e v) - -instance UnionWithExcept (ExceptT e u v) u e v where - extractUnionExcept = runExceptT - --- | --- Solver procedure for programs with error handling. --- --- >>> import Control.Monad.Except --- >>> let x = "x" :: SymInteger --- >>> :{ --- res :: ExceptT AssertionError Union () --- res = do --- symAssert $ x .> 0 -- constrain that x is positive --- symAssert $ x .< 2 -- constrain that x is less than 2 --- :} --- --- >>> :{ --- translate (Left _) = con False -- errors are not desirable --- translate _ = con True -- non-errors are desirable --- :} --- --- >>> solveExcept z3 translate res --- Right (Model {x -> 1 :: Integer}) -solveExcept :: - ( UnionWithExcept t u e v, - 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 = - withSolver config $ - \solver -> solverSolveExcept solver f v - --- | --- Solver procedure for programs with error handling. Would return multiple --- models if possible. -solveMultiExcept :: - ( UnionWithExcept t u e v, - 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 = - withSolver config $ - \solver -> solverSolveMultiExcept solver n f v +import Grisette.Internal.Internal.Decl.Core.Data.Class.Solver +import Grisette.Internal.Internal.Impl.Core.Data.Class.Solver () diff --git a/src/Grisette/Internal/Core/Data/Class/SubstSym.hs b/src/Grisette/Internal/Core/Data/Class/SubstSym.hs --- a/src/Grisette/Internal/Core/Data/Class/SubstSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/SubstSym.hs @@ -1,18 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.SubstSym @@ -38,618 +24,5 @@ ) where -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import qualified Data.HashSet as HS -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator, (%)) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Default1 (Default1, unDefault1), - Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Generics.Deriving.Instances () -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->) (GeneralFun)) -import Grisette.Internal.SymPrim.Prim.Term - ( IsSymbolKind, - LinkedRep (underlyingTerm), - SymRep (SymType), - SymbolKind, - TypedSymbol, - someTypedSymbol, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | Substitution of symbols (symbolic constants) to a symbolic value. --- --- >>> a = "a" :: TypedAnySymbol Bool --- >>> v = "x" .&& "y" :: SymBool --- >>> substSym a v (["a" .&& "b", "a"] :: [SymBool]) --- [(&& (&& x y) b),(&& x y)] --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SubstSym via (Default X) -class SubstSym a where - -- Substitute a symbolic constant to some symbolic value - -- - -- >>> substSym "a" ("c" .&& "d" :: Sym Bool) ["a" .&& "b" :: Sym Bool, "a"] - -- [(&& (&& c d) b),(&& c d)] - substSym :: - (LinkedRep cb sb, IsSymbolKind knd) => - TypedSymbol knd cb -> - sb -> - a -> - a - --- | Lifting of 'SubstSym' to unary type constructors. -class - (forall a. (SubstSym a) => SubstSym (f a)) => - SubstSym1 f - where - -- | Lift a symbol substitution function to unary type constructors. - liftSubstSym :: - (LinkedRep cb sb, IsSymbolKind knd) => - (TypedSymbol knd cb -> sb -> a -> a) -> - TypedSymbol knd cb -> - sb -> - f a -> - f a - --- | Lifting the standard 'substSym' to unary type constructors. -substSym1 :: - (SubstSym1 f, SubstSym a, LinkedRep cb sb, IsSymbolKind knd) => - TypedSymbol knd cb -> - sb -> - f a -> - f a -substSym1 = liftSubstSym substSym - --- | Lifting of 'SubstSym' to binary type constructors. -class - (forall a. (SubstSym a) => SubstSym1 (f a)) => - SubstSym2 f - where - -- | Lift a symbol substitution function to binary type constructors. - liftSubstSym2 :: - (LinkedRep cb sb, IsSymbolKind knd) => - (TypedSymbol knd cb -> sb -> a -> a) -> - (TypedSymbol knd cb -> sb -> b -> b) -> - TypedSymbol knd cb -> - sb -> - f a b -> - f a b - --- | Lifting the standard 'substSym' to binary type constructors. -substSym2 :: - (SubstSym2 f, SubstSym a, SubstSym b, LinkedRep cb sb, IsSymbolKind knd) => - TypedSymbol knd cb -> - sb -> - f a b -> - f a b -substSym2 = liftSubstSym2 substSym substSym - --- Derivations - --- | The arguments to the generic 'substSym' function. -data family SubstSymArgs arity (knd :: SymbolKind) a cb sb :: Type - -data instance SubstSymArgs Arity0 _ _ _ _ = SubstSymArgs0 - -newtype instance SubstSymArgs Arity1 knd a cb sb - = SubstSymArgs1 (TypedSymbol knd cb -> sb -> a -> a) - --- | The class of types where we can generically substitute the symbols in a --- value. -class GSubstSym arity f where - gsubstSym :: - (LinkedRep cb sb, IsSymbolKind knd) => - SubstSymArgs arity knd a cb sb -> - TypedSymbol knd cb -> - sb -> - f a -> - f a - -instance GSubstSym arity V1 where - gsubstSym _ _ _ = id - {-# INLINE gsubstSym #-} - -instance GSubstSym arity U1 where - gsubstSym _ _ _ = id - {-# INLINE gsubstSym #-} - -instance (SubstSym a) => GSubstSym arity (K1 i a) where - gsubstSym _ sym val (K1 v) = K1 $ substSym sym val v - {-# INLINE gsubstSym #-} - -instance (GSubstSym arity a) => GSubstSym arity (M1 i c a) where - gsubstSym args sym val (M1 v) = M1 $ gsubstSym args sym val v - {-# INLINE gsubstSym #-} - -instance (GSubstSym arity a, GSubstSym arity b) => GSubstSym arity (a :*: b) where - gsubstSym args sym val (a :*: b) = - gsubstSym args sym val a :*: gsubstSym args sym val b - {-# INLINE gsubstSym #-} - -instance (GSubstSym arity a, GSubstSym arity b) => GSubstSym arity (a :+: b) where - gsubstSym args sym val (L1 l) = L1 $ gsubstSym args sym val l - gsubstSym args sym val (R1 r) = R1 $ gsubstSym args sym val r - {-# INLINE gsubstSym #-} - -instance (SubstSym1 a) => GSubstSym Arity1 (Rec1 a) where - gsubstSym (SubstSymArgs1 f) sym val (Rec1 v) = - Rec1 $ liftSubstSym f sym val v - {-# INLINE gsubstSym #-} - -instance GSubstSym Arity1 Par1 where - gsubstSym (SubstSymArgs1 f) sym val (Par1 v) = Par1 $ f sym val v - {-# INLINE gsubstSym #-} - -instance - (SubstSym1 f, GSubstSym Arity1 g) => - GSubstSym Arity1 (f :.: g) - where - gsubstSym targs sym val (Comp1 x) = - Comp1 $ liftSubstSym (gsubstSym targs) sym val x - {-# INLINE gsubstSym #-} - --- | Generic 'substSym' function. -genericSubstSym :: - (Generic a, GSubstSym Arity0 (Rep a), LinkedRep cb sb, IsSymbolKind knd) => - TypedSymbol knd cb -> - sb -> - a -> - a -genericSubstSym sym val = - to . gsubstSym SubstSymArgs0 sym val . from -{-# INLINE genericSubstSym #-} - --- | Generic 'liftSubstSym' function. -genericLiftSubstSym :: - (Generic1 f, GSubstSym Arity1 (Rep1 f), LinkedRep cb sb, IsSymbolKind knd) => - (TypedSymbol knd cb -> sb -> a -> a) -> - TypedSymbol knd cb -> - sb -> - f a -> - f a -genericLiftSubstSym f sym val = - to1 . gsubstSym (SubstSymArgs1 f) sym val . from1 -{-# INLINE genericLiftSubstSym #-} - -instance - (Generic a, GSubstSym Arity0 (Rep a)) => - SubstSym (Default a) - where - substSym sym val = Default . genericSubstSym sym val . unDefault - {-# INLINE substSym #-} - -instance - (Generic1 f, GSubstSym Arity1 (Rep1 f), SubstSym a) => - SubstSym (Default1 f a) - where - substSym = substSym1 - {-# INLINE substSym #-} - -instance - (Generic1 f, GSubstSym Arity1 (Rep1 f)) => - SubstSym1 (Default1 f) - where - liftSubstSym f sym val = - Default1 . genericLiftSubstSym f sym val . unDefault1 - {-# INLINE liftSubstSym #-} - -#define CONCRETE_SUBSTITUTESYM(type) \ -instance SubstSym type where \ - substSym _ _ = id - -#define CONCRETE_SUBSTITUTESYM_BV(type) \ -instance (KnownNat n, 1 <= n) => SubstSym (type n) where \ - substSym _ _ = id - -#if 1 -CONCRETE_SUBSTITUTESYM(Bool) -CONCRETE_SUBSTITUTESYM(Integer) -CONCRETE_SUBSTITUTESYM(Char) -CONCRETE_SUBSTITUTESYM(Int) -CONCRETE_SUBSTITUTESYM(Int8) -CONCRETE_SUBSTITUTESYM(Int16) -CONCRETE_SUBSTITUTESYM(Int32) -CONCRETE_SUBSTITUTESYM(Int64) -CONCRETE_SUBSTITUTESYM(Word) -CONCRETE_SUBSTITUTESYM(Word8) -CONCRETE_SUBSTITUTESYM(Word16) -CONCRETE_SUBSTITUTESYM(Word32) -CONCRETE_SUBSTITUTESYM(Word64) -CONCRETE_SUBSTITUTESYM(Float) -CONCRETE_SUBSTITUTESYM(Double) -CONCRETE_SUBSTITUTESYM(B.ByteString) -CONCRETE_SUBSTITUTESYM(T.Text) -CONCRETE_SUBSTITUTESYM(Monoid.All) -CONCRETE_SUBSTITUTESYM(Monoid.Any) -CONCRETE_SUBSTITUTESYM(Ordering) -CONCRETE_SUBSTITUTESYM_BV(WordN) -CONCRETE_SUBSTITUTESYM_BV(IntN) -CONCRETE_SUBSTITUTESYM(FPRoundingMode) -CONCRETE_SUBSTITUTESYM(AlgReal) -#endif - -instance (Integral a, SubstSym a) => SubstSym (Ratio a) where - substSym sym val a = - substSym sym val (numerator a) % substSym sym val (denominator a) - {-# INLINE substSym #-} - -instance (ValidFP eb sb) => SubstSym (FP eb sb) where - substSym _ _ = id - -#define SUBSTITUTE_SYM_SIMPLE(symtype) \ -instance SubstSym symtype where \ - substSym sym v (symtype t) = \ - symtype $ substTerm sym (underlyingTerm v) HS.empty t - -#define SUBSTITUTE_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SubstSym (symtype n) where \ - substSym sym v (symtype t) = \ - symtype $ substTerm sym (underlyingTerm v) HS.empty t - -#define SUBSTITUTE_SYM_FUN(op, cons) \ -instance SubstSym (op sa sb) where \ - substSym sym v (cons t) = \ - cons $ substTerm sym (underlyingTerm v) HS.empty t - -#if 1 -SUBSTITUTE_SYM_SIMPLE(SymBool) -SUBSTITUTE_SYM_SIMPLE(SymInteger) -SUBSTITUTE_SYM_SIMPLE(SymAlgReal) -SUBSTITUTE_SYM_BV(SymIntN) -SUBSTITUTE_SYM_BV(SymWordN) -SUBSTITUTE_SYM_FUN((=~>), SymTabularFun) -SUBSTITUTE_SYM_FUN((-~>), SymGeneralFun) -SUBSTITUTE_SYM_SIMPLE(SymFPRoundingMode) -#endif - -instance (ValidFP eb sb) => SubstSym (SymFP eb sb) where - substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) HS.empty t - --- Instances -deriveBuiltins - (ViaDefault ''SubstSym) - [''SubstSym] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''SubstSym1) - [''SubstSym, ''SubstSym1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- ExceptT -instance - (SubstSym1 m, SubstSym e, SubstSym a) => - SubstSym (ExceptT e m a) - where - substSym = substSym1 - {-# INLINE substSym #-} - -instance - (SubstSym1 m, SubstSym e) => - SubstSym1 (ExceptT e m) - where - liftSubstSym f sym val (ExceptT v) = - ExceptT $ liftSubstSym (liftSubstSym f) sym val v - {-# INLINE liftSubstSym #-} - --- MaybeT -instance - (SubstSym1 m, SubstSym a) => - SubstSym (MaybeT m a) - where - substSym = substSym1 - {-# INLINE substSym #-} - -instance - (SubstSym1 m) => - SubstSym1 (MaybeT m) - where - liftSubstSym f sym val (MaybeT v) = - MaybeT $ liftSubstSym (liftSubstSym f) sym val v - {-# INLINE liftSubstSym #-} - --- WriterT -instance - (SubstSym1 m, SubstSym a, SubstSym s) => - SubstSym (WriterLazy.WriterT s m a) - where - substSym = substSym1 - {-# INLINE substSym #-} - -instance - (SubstSym1 m, SubstSym s) => - SubstSym1 (WriterLazy.WriterT s m) - where - liftSubstSym f sym val (WriterLazy.WriterT v) = - WriterLazy.WriterT $ - liftSubstSym (liftSubstSym2 f substSym) sym val v - {-# INLINE liftSubstSym #-} - -instance - (SubstSym1 m, SubstSym a, SubstSym s) => - SubstSym (WriterStrict.WriterT s m a) - where - substSym = substSym1 - {-# INLINE substSym #-} - -instance - (SubstSym1 m, SubstSym s) => - SubstSym1 (WriterStrict.WriterT s m) - where - liftSubstSym f sym val (WriterStrict.WriterT v) = - WriterStrict.WriterT $ - liftSubstSym (liftSubstSym2 f substSym) sym val v - {-# INLINE liftSubstSym #-} - --- IdentityT -instance - (SubstSym1 m, SubstSym a) => - SubstSym (IdentityT m a) - where - substSym = substSym1 - {-# INLINE substSym #-} - -instance (SubstSym1 m) => SubstSym1 (IdentityT m) where - liftSubstSym f sym val (IdentityT a) = - IdentityT $ liftSubstSym f sym val a - {-# INLINE liftSubstSym #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (SubstSym (l a), SubstSym (r a)) => SubstSym (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (SubstSym1 l, SubstSym1 r) => SubstSym1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (SubstSym (l a), SubstSym (r a)) => SubstSym (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (SubstSym1 l, SubstSym1 r) => SubstSym1 (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (SubstSym (f (g a))) => SubstSym (Compose f g a) - -instance - (SubstSym1 f, SubstSym1 g) => - SubstSym1 (Compose f g) - where - liftSubstSym f sym val (Compose x) = - Compose $ liftSubstSym (liftSubstSym f) sym val x - {-# INLINE liftSubstSym #-} - --- Const -deriving via - (Default (Const a b)) - instance - (SubstSym a) => SubstSym (Const a b) - -deriving via - (Default1 (Const a)) - instance - (SubstSym a) => SubstSym1 (Const a) - --- Alt -deriving via - (Default (Alt f a)) - instance - (SubstSym (f a)) => SubstSym (Alt f a) - -deriving via - (Default1 (Alt f)) - instance - (SubstSym1 f) => SubstSym1 (Alt f) - --- Ap -deriving via - (Default (Ap f a)) - instance - (SubstSym (f a)) => SubstSym (Ap f a) - -deriving via - (Default1 (Ap f)) - instance - (SubstSym1 f) => SubstSym1 (Ap f) - --- Generic -deriving via (Default (U1 p)) instance SubstSym (U1 p) - -deriving via (Default (V1 p)) instance SubstSym (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (SubstSym c) => SubstSym (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (SubstSym (f p)) => SubstSym (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (SubstSym (f p), SubstSym (g p)) => SubstSym ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (SubstSym (f p), SubstSym (g p)) => SubstSym ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (SubstSym p) => SubstSym (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (SubstSym (f p)) => SubstSym (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (SubstSym (f (g p))) => SubstSym ((f :.: g) p) - --- SubstSym2 -instance SubstSym2 Either where - liftSubstSym2 f _ sym val (Left x) = Left $ f sym val x - liftSubstSym2 _ g sym val (Right y) = Right $ g sym val y - {-# INLINE liftSubstSym2 #-} - -instance SubstSym2 (,) where - liftSubstSym2 f g sym val (x, y) = (f sym val x, g sym val y) - {-# INLINE liftSubstSym2 #-} - -instance (SubstSym a) => SubstSym2 ((,,) a) where - liftSubstSym2 f g sym val (x, y, z) = - (substSym sym val x, f sym val y, g sym val z) - {-# INLINE liftSubstSym2 #-} - -instance (SubstSym a, SubstSym b) => SubstSym2 ((,,,) a b) where - liftSubstSym2 f g sym val (x, y, z, w) = - (substSym sym val x, substSym sym val y, f sym val z, g sym val w) - {-# INLINE liftSubstSym2 #-} - -instance (SubstSym a, SubstSym b) => SubstSym (a =-> b) where - substSym sym val (TabularFun f d) = - TabularFun (substSym sym val f) (substSym sym val d) - {-# INLINE substSym #-} - -instance (SubstSym (SymType b)) => SubstSym (a --> b) where - substSym sym val (GeneralFun s t) = - GeneralFun s $ - substTerm sym (underlyingTerm val) (HS.singleton $ someTypedSymbol s) t - {-# INLINE substSym #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym +import Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym () diff --git a/src/Grisette/Internal/Core/Data/Class/SymEq.hs b/src/Grisette/Internal/Core/Data/Class/SymEq.hs --- a/src/Grisette/Internal/Core/Data/Class/SymEq.hs +++ b/src/Grisette/Internal/Core/Data/Class/SymEq.hs @@ -1,18 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.SymEq @@ -42,561 +28,5 @@ ) where -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Default1 (Default1), - Generic (Rep, from), - Generic1 (Rep1, from1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.Prim.Term - ( SupportedPrim (pevalDistinctTerm), - pevalEqTerm, - underlyingTerm, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- | Check if all elements in a list are distinct. --- --- Note that empty or singleton lists are always distinct. --- --- >>> distinct [] --- True --- >>> distinct [1] --- True --- >>> distinct [1, 2, 3] --- True --- >>> distinct [1, 2, 2] --- False -distinct :: (Eq a) => [a] -> Bool -distinct [] = True -distinct [_] = True -distinct (x : xs) = go x xs && distinct xs - where - go _ [] = True - go x' (y : ys) = x' /= y .&& go x' ys - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since --- symbolic comparison won't necessarily return a concrete 'Bool' value. --- --- >>> let a = 1 :: SymInteger --- >>> let b = 2 :: SymInteger --- >>> a .== b --- false --- >>> a ./= b --- true --- --- >>> let a = "a" :: SymInteger --- >>> let b = "b" :: SymInteger --- >>> a .== b --- (= a b) --- >>> a ./= b --- (distinct a b) --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SymEq via (Default X) -class SymEq a where - (.==) :: a -> a -> SymBool - a .== b = symNot $ a ./= b - {-# INLINE (.==) #-} - infix 4 .== - - (./=) :: a -> a -> SymBool - a ./= b = symNot $ a .== b - {-# INLINE (./=) #-} - infix 4 ./= - - -- | Check if all elements in a list are distinct, under the symbolic equality - -- semantics. - symDistinct :: [a] -> SymBool - symDistinct = pairwiseSymDistinct - - {-# MINIMAL (.==) | (./=) #-} - --- | Default pairwise symbolic distinct implementation. -pairwiseSymDistinct :: (SymEq a) => [a] -> SymBool -pairwiseSymDistinct [] = con True -pairwiseSymDistinct [_] = con True -pairwiseSymDistinct (x : xs) = go x xs .&& pairwiseSymDistinct xs - where - go _ [] = con True - go x' (y : ys) = x' ./= y .&& go x' ys - --- | Lifting of the 'SymEq' class to unary type constructors. --- --- Any instance should be subject to the following law that canonicity is --- preserved: --- --- @liftSymEq (.==)@ should be equivalent to @(.==)@, under the symbolic --- semantics. --- --- This class therefore represents the generalization of 'SymEq' by decomposing --- its main method into a canonical lifting on a canonical inner method, so that --- the lifting can be reused for other arguments than the canonical one. -class (forall a. (SymEq a) => SymEq (f a)) => SymEq1 f where - -- | Lift a symbolic equality test through the type constructor. - -- - -- The function will usually be applied to an symbolic equality function, but - -- the more general type ensures that the implementation uses it to compare - -- elements of the first container with elements of the second. - liftSymEq :: (a -> b -> SymBool) -> f a -> f b -> SymBool - --- | Lift the standard @('.==')@ function through the type constructor. -symEq1 :: (SymEq a, SymEq1 f) => f a -> f a -> SymBool -symEq1 = liftSymEq (.==) - --- | Lifting of the 'SymEq' class to binary type constructors. -class (forall a. (SymEq a) => SymEq1 (f a)) => SymEq2 f where - -- | Lift symbolic equality tests through the type constructor. - -- - -- The function will usually be applied to an symbolic equality function, but - -- the more general type ensures that the implementation uses it to compare - -- elements of the first container with elements of the second. - liftSymEq2 :: - (a -> b -> SymBool) -> - (c -> d -> SymBool) -> - f a c -> - f b d -> - SymBool - --- | Lift the standard @('.==')@ function through the type constructor. -symEq2 :: (SymEq a, SymEq b, SymEq2 f) => f a b -> f a b -> SymBool -symEq2 = liftSymEq2 (.==) (.==) - --- Derivations - --- | The arguments to the generic equality function. -data family SymEqArgs arity a b :: Type - -data instance SymEqArgs Arity0 _ _ = SymEqArgs0 - -newtype instance SymEqArgs Arity1 a b = SymEqArgs1 (a -> b -> SymBool) - --- | The class of types that can be generically compared for symbolic equality. -class GSymEq arity f where - gsymEq :: SymEqArgs arity a b -> f a -> f b -> SymBool - -instance GSymEq arity V1 where - gsymEq _ _ _ = con True - {-# INLINE gsymEq #-} - -instance GSymEq arity U1 where - gsymEq _ _ _ = con True - {-# INLINE gsymEq #-} - -instance (GSymEq arity a, GSymEq arity b) => GSymEq arity (a :*: b) where - gsymEq args (a1 :*: b1) (a2 :*: b2) = gsymEq args a1 a2 .&& gsymEq args b1 b2 - {-# INLINE gsymEq #-} - -instance (GSymEq arity a, GSymEq arity b) => GSymEq arity (a :+: b) where - gsymEq args (L1 a1) (L1 a2) = gsymEq args a1 a2 - gsymEq args (R1 b1) (R1 b2) = gsymEq args b1 b2 - gsymEq _ _ _ = con False - {-# INLINE gsymEq #-} - -instance (GSymEq arity a) => GSymEq arity (M1 i c a) where - gsymEq args (M1 a1) (M1 a2) = gsymEq args a1 a2 - {-# INLINE gsymEq #-} - -instance (SymEq a) => GSymEq arity (K1 i a) where - gsymEq _ (K1 a) (K1 b) = a .== b - {-# INLINE gsymEq #-} - -instance GSymEq Arity1 Par1 where - gsymEq (SymEqArgs1 e) (Par1 a) (Par1 b) = e a b - {-# INLINE gsymEq #-} - -instance (SymEq1 f) => GSymEq Arity1 (Rec1 f) where - gsymEq (SymEqArgs1 e) (Rec1 a) (Rec1 b) = liftSymEq e a b - {-# INLINE gsymEq #-} - -instance (SymEq1 f, GSymEq Arity1 g) => GSymEq Arity1 (f :.: g) where - gsymEq targs (Comp1 a) (Comp1 b) = liftSymEq (gsymEq targs) a b - {-# INLINE gsymEq #-} - -instance (Generic a, GSymEq Arity0 (Rep a)) => SymEq (Default a) where - Default l .== Default r = genericSymEq l r - {-# INLINE (.==) #-} - --- | Generic @('.==')@ function. -genericSymEq :: (Generic a, GSymEq Arity0 (Rep a)) => a -> a -> SymBool -genericSymEq l r = gsymEq SymEqArgs0 (from l) (from r) -{-# INLINE genericSymEq #-} - -instance (Generic1 f, GSymEq Arity1 (Rep1 f), SymEq a) => SymEq (Default1 f a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance (Generic1 f, GSymEq Arity1 (Rep1 f)) => SymEq1 (Default1 f) where - liftSymEq f (Default1 l) (Default1 r) = genericLiftSymEq f l r - {-# INLINE liftSymEq #-} - --- | Generic 'liftSymEq' function. -genericLiftSymEq :: - (Generic1 f, GSymEq Arity1 (Rep1 f)) => - (a -> b -> SymBool) -> - f a -> - f b -> - SymBool -genericLiftSymEq f l r = gsymEq (SymEqArgs1 f) (from1 l) (from1 r) -{-# INLINE genericLiftSymEq #-} - -#define CONCRETE_SEQ(type) \ -instance SymEq type where \ - l .== r = con $ l == r; \ - {-# INLINE (.==) #-} - -#define CONCRETE_SEQ_BV(type) \ -instance (KnownNat n, 1 <= n) => SymEq (type n) where \ - l .== r = con $ l == r; \ - {-# INLINE (.==) #-} - -#if 1 -CONCRETE_SEQ(Bool) -CONCRETE_SEQ(Integer) -CONCRETE_SEQ(Char) -CONCRETE_SEQ(Int) -CONCRETE_SEQ(Int8) -CONCRETE_SEQ(Int16) -CONCRETE_SEQ(Int32) -CONCRETE_SEQ(Int64) -CONCRETE_SEQ(Word) -CONCRETE_SEQ(Word8) -CONCRETE_SEQ(Word16) -CONCRETE_SEQ(Word32) -CONCRETE_SEQ(Word64) -CONCRETE_SEQ(Float) -CONCRETE_SEQ(Double) -CONCRETE_SEQ(B.ByteString) -CONCRETE_SEQ(T.Text) -CONCRETE_SEQ(FPRoundingMode) -CONCRETE_SEQ(Monoid.All) -CONCRETE_SEQ(Monoid.Any) -CONCRETE_SEQ(Ordering) -CONCRETE_SEQ_BV(WordN) -CONCRETE_SEQ_BV(IntN) -CONCRETE_SEQ(AlgReal) -#endif - -instance (SymEq a) => SymEq (Ratio a) where - a .== b = numerator a .== numerator b .&& denominator a .== denominator b - {-# INLINE (.==) #-} - -instance (ValidFP eb sb) => SymEq (FP eb sb) where - l .== r = con $ l == r - {-# INLINE (.==) #-} - --- Symbolic types -#define SEQ_SIMPLE(symtype) \ -instance SymEq symtype where \ - (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ - {-# INLINE (.==) #-}; \ - l ./= r = symDistinct [l, r]; \ - {-# INLINE (./=) #-}; \ - symDistinct [] = con True; \ - symDistinct [_] = con True; \ - symDistinct (l:ls) = SymBool $ \ - pevalDistinctTerm (underlyingTerm l :| (underlyingTerm <$> ls)) - -#define SEQ_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SymEq (symtype n) where \ - (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ - {-# INLINE (.==) #-}; \ - l ./= r = symDistinct [l, r]; \ - {-# INLINE (./=) #-}; \ - symDistinct [] = con True; \ - symDistinct [_] = con True; \ - symDistinct (l:ls) = SymBool $ \ - pevalDistinctTerm (underlyingTerm l :| (underlyingTerm <$> ls)) - -#if 1 -SEQ_SIMPLE(SymBool) -SEQ_SIMPLE(SymInteger) -SEQ_SIMPLE(SymFPRoundingMode) -SEQ_SIMPLE(SymAlgReal) -SEQ_BV(SymIntN) -SEQ_BV(SymWordN) -#endif - -instance (ValidFP eb sb) => SymEq (SymFP eb sb) where - (SymFP l) .== (SymFP r) = SymBool $ pevalEqTerm l r - {-# INLINE (.==) #-} - --- Instances -deriveBuiltins - (ViaDefault ''SymEq) - [''SymEq] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] -deriveBuiltins - (ViaDefault1 ''SymEq1) - [''SymEq, ''SymEq1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- ExceptT -instance (SymEq1 m, SymEq e, SymEq a) => SymEq (ExceptT e m a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance (SymEq1 m, SymEq e) => SymEq1 (ExceptT e m) where - liftSymEq f (ExceptT l) (ExceptT r) = liftSymEq (liftSymEq f) l r - {-# INLINE liftSymEq #-} - --- MaybeT -instance (SymEq1 m, SymEq a) => SymEq (MaybeT m a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance (SymEq1 m) => SymEq1 (MaybeT m) where - liftSymEq f (MaybeT l) (MaybeT r) = liftSymEq (liftSymEq f) l r - {-# INLINE liftSymEq #-} - --- Writer -instance (SymEq1 m, SymEq w, SymEq a) => SymEq (WriterLazy.WriterT w m a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance (SymEq1 m, SymEq w) => SymEq1 (WriterLazy.WriterT w m) where - liftSymEq f (WriterLazy.WriterT l) (WriterLazy.WriterT r) = - liftSymEq (liftSymEq2 f (.==)) l r - {-# INLINE liftSymEq #-} - -instance (SymEq1 m, SymEq w, SymEq a) => SymEq (WriterStrict.WriterT w m a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance (SymEq1 m, SymEq w) => SymEq1 (WriterStrict.WriterT w m) where - liftSymEq f (WriterStrict.WriterT l) (WriterStrict.WriterT r) = - liftSymEq (liftSymEq2 f (.==)) l r - {-# INLINE liftSymEq #-} - --- IdentityT -instance (SymEq1 m, SymEq a) => SymEq (IdentityT m a) where - (.==) = symEq1 - {-# INLINE (.==) #-} - -instance (SymEq1 m) => SymEq1 (IdentityT m) where - liftSymEq f (IdentityT l) (IdentityT r) = liftSymEq f l r - {-# INLINE liftSymEq #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (SymEq (l a), SymEq (r a)) => SymEq (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (SymEq1 l, SymEq1 r) => SymEq1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (SymEq (l a), SymEq (r a)) => SymEq (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (SymEq1 l, SymEq1 r) => SymEq1 (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (SymEq (f (g a))) => SymEq (Compose f g a) - -instance (SymEq1 f, SymEq1 g) => SymEq1 (Compose f g) where - liftSymEq f (Compose l) (Compose r) = liftSymEq (liftSymEq f) l r - --- Const -deriving via (Default (Const a b)) instance (SymEq a) => SymEq (Const a b) - -deriving via (Default1 (Const a)) instance (SymEq a) => SymEq1 (Const a) - --- Alt -deriving via (Default (Alt f a)) instance (SymEq (f a)) => SymEq (Alt f a) - -deriving via (Default1 (Alt f)) instance (SymEq1 f) => SymEq1 (Alt f) - --- Ap -deriving via (Default (Ap f a)) instance (SymEq (f a)) => SymEq (Ap f a) - -deriving via (Default1 (Ap f)) instance (SymEq1 f) => SymEq1 (Ap f) - --- Generic -deriving via (Default (U1 p)) instance SymEq (U1 p) - -deriving via (Default (V1 p)) instance SymEq (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (SymEq c) => SymEq (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (SymEq (f p)) => SymEq (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (SymEq (f p), SymEq (g p)) => SymEq ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (SymEq (f p), SymEq (g p)) => SymEq ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (SymEq p) => SymEq (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (SymEq (f p)) => SymEq (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (SymEq (f (g p))) => SymEq ((f :.: g) p) - -instance SymEq2 Either where - liftSymEq2 f _ (Left l) (Left r) = f l r - liftSymEq2 _ g (Right l) (Right r) = g l r - liftSymEq2 _ _ _ _ = con False - {-# INLINE liftSymEq2 #-} - -instance SymEq2 (,) where - liftSymEq2 f g (l1, l2) (r1, r2) = f l1 r1 .&& g l2 r2 - {-# INLINE liftSymEq2 #-} - -instance (SymEq a) => SymEq2 ((,,) a) where - liftSymEq2 f g (l1, l2, l3) (r1, r2, r3) = l1 .== r1 .&& f l2 r2 .&& g l3 r3 - {-# INLINE liftSymEq2 #-} - -instance (SymEq a, SymEq b) => SymEq2 ((,,,) a b) where - liftSymEq2 f g (l1, l2, l3, l4) (r1, r2, r3, r4) = - l1 .== r1 .&& l2 .== r2 .&& f l3 r3 .&& g l4 r4 - {-# INLINE liftSymEq2 #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq +import Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq () diff --git a/src/Grisette/Internal/Core/Data/Class/SymOrd.hs b/src/Grisette/Internal/Core/Data/Class/SymOrd.hs --- a/src/Grisette/Internal/Core/Data/Class/SymOrd.hs +++ b/src/Grisette/Internal/Core/Data/Class/SymOrd.hs @@ -1,19 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.SymOrd @@ -45,775 +30,5 @@ ) where -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down (Down)) -import Data.Ratio (Ratio, denominator, numerator) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeLits (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Default1 (Default1), - Generic (Rep, from), - Generic1 (Rep1, from1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Control.Monad.Union (Union) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp, symIte) -import Grisette.Internal.Core.Data.Class.LogicalOp - ( LogicalOp (symNot, (.&&), (.||)), - ) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( simpleMerge, - ) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SymBranching, - mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.Core.Data.Class.SymEq - ( GSymEq, - SymEq ((.==)), - SymEq1, - SymEq2, - ) -import Grisette.Internal.Core.Data.Class.TryMerge - ( mrgSingle, - tryMerge, - ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) -import Grisette.Internal.SymPrim.Prim.Term - ( PEvalOrdTerm - ( pevalLeOrdTerm, - pevalLtOrdTerm - ), - pevalGeOrdTerm, - pevalGtOrdTerm, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since --- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' --- value. --- --- >>> let a = 1 :: SymInteger --- >>> let b = 2 :: SymInteger --- >>> a .< b --- true --- >>> a .> b --- false --- --- >>> let a = "a" :: SymInteger --- >>> let b = "b" :: SymInteger --- >>> a .< b --- (< a b) --- >>> a .<= b --- (<= a b) --- >>> a .> b --- (< b a) --- >>> a .>= b --- (<= b a) --- --- For `symCompare`, `Ordering` is not a solvable type, and the result would --- be wrapped in a union-like monad. See --- `Grisette.Core.Control.Monad.Union` and `Grisette.Core.PlainUnion` for more --- information. --- --- >>> a `symCompare` b :: Union Ordering --- {If (< a b) LT (If (= a b) EQ GT)} --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SymOrd via (Default X) -class (SymEq a) => SymOrd a where - (.<) :: a -> a -> SymBool - infix 4 .< - (.<=) :: a -> a -> SymBool - infix 4 .<= - (.>) :: a -> a -> SymBool - infix 4 .> - (.>=) :: a -> a -> SymBool - infix 4 .>= - x .< y = - simpleMerge $ - symCompare x y >>= \case - LT -> con True - EQ -> con False - GT -> con False - {-# INLINE (.<) #-} - x .<= y = symNot (x .> y) - {-# INLINE (.<=) #-} - x .> y = y .< x - {-# INLINE (.>) #-} - x .>= y = y .<= x - {-# INLINE (.>=) #-} - symCompare :: a -> a -> Union Ordering - symCompare l r = - mrgIf - (l .< r) - (mrgSingle LT) - (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) - {-# INLINE symCompare #-} - {-# MINIMAL (.<) | symCompare #-} - --- | Lifting of the 'SymOrd' class to unary type constructors. --- --- Any instance should be subject to the following law that canonicity is --- preserved: --- --- @liftSymCompare symCompare@ should be equivalent to @symCompare@, under the --- symbolic semantics. --- --- This class therefore represents the generalization of 'SymOrd' by decomposing --- its main method into a canonical lifting on a canonical inner method, so that --- the lifting can be reused for other arguments than the canonical one. -class (SymEq1 f, forall a. (SymOrd a) => SymOrd (f a)) => SymOrd1 f where - -- | Lift a 'symCompare' function through the type constructor. - -- - -- The function will usually be applied to an symbolic comparison function, - -- but the more general type ensures that the implementation uses it to - -- compare elements of the first container with elements of the second. - liftSymCompare :: (a -> b -> Union Ordering) -> f a -> f b -> Union Ordering - --- | Lift the standard 'symCompare' function to binary type constructors. -symCompare1 :: (SymOrd1 f, SymOrd a) => f a -> f a -> Union Ordering -symCompare1 = liftSymCompare symCompare -{-# INLINE symCompare1 #-} - --- | Lifting of the 'SymOrd' class to binary type constructors. -class (SymEq2 f, forall a. (SymOrd a) => SymOrd1 (f a)) => SymOrd2 f where - -- | Lift a 'symCompare' function through the type constructor. - -- - -- The function will usually be applied to an symbolic comparison function, - -- but the more general type ensures that the implementation uses it to - -- compare elements of the first container with elements of the second. - liftSymCompare2 :: - (a -> b -> Union Ordering) -> - (c -> d -> Union Ordering) -> - f a c -> - f b d -> - Union Ordering - --- | Lift the standard 'symCompare' function through the type constructors. -symCompare2 :: (SymOrd2 f, SymOrd a, SymOrd b) => f a b -> f a b -> Union Ordering -symCompare2 = liftSymCompare2 symCompare symCompare -{-# INLINE symCompare2 #-} - --- | Symbolic maximum. -symMax :: (SymOrd a, ITEOp a) => a -> a -> a -symMax x y = symIte (x .>= y) x y -{-# INLINE symMax #-} - --- | Symbolic minimum. -symMin :: (SymOrd a, ITEOp a) => a -> a -> a -symMin x y = symIte (x .>= y) y x -{-# INLINE symMin #-} - --- | Symbolic maximum, with a union-like monad. -mrgMax :: - (SymOrd a, Mergeable a, SymBranching m, Applicative m) => - a -> - a -> - m a -mrgMax x y = mrgIf (x .>= y) (pure x) (pure y) -{-# INLINE mrgMax #-} - --- | Symbolic minimum, with a union-like monad. -mrgMin :: - (SymOrd a, Mergeable a, SymBranching m, Applicative m) => - a -> - a -> - m a -mrgMin x y = mrgIf (x .>= y) (pure y) (pure x) -{-# INLINE mrgMin #-} - --- Derivations - --- | The arguments to the generic comparison function. -data family SymOrdArgs arity a b :: Type - -data instance SymOrdArgs Arity0 _ _ = SymOrdArgs0 - -newtype instance SymOrdArgs Arity1 a b - = SymOrdArgs1 (a -> b -> Union Ordering) - --- | The class of types that can be generically symbolically compared. -class GSymOrd arity f where - gsymCompare :: SymOrdArgs arity a b -> f a -> f b -> Union Ordering - -instance GSymOrd arity V1 where - gsymCompare _ _ _ = mrgSingle EQ - {-# INLINE gsymCompare #-} - -instance GSymOrd arity U1 where - gsymCompare _ _ _ = mrgSingle EQ - {-# INLINE gsymCompare #-} - -instance - (GSymOrd arity a, GSymOrd arity b) => - GSymOrd arity (a :*: b) - where - gsymCompare args (a1 :*: b1) (a2 :*: b2) = do - l <- gsymCompare args a1 a2 - case l of - EQ -> gsymCompare args b1 b2 - _ -> mrgSingle l - {-# INLINE gsymCompare #-} - -instance - (GSymOrd arity a, GSymOrd arity b) => - GSymOrd arity (a :+: b) - where - gsymCompare args (L1 a) (L1 b) = gsymCompare args a b - gsymCompare _ (L1 _) (R1 _) = mrgSingle LT - gsymCompare args (R1 a) (R1 b) = gsymCompare args a b - gsymCompare _ (R1 _) (L1 _) = mrgSingle GT - {-# INLINE gsymCompare #-} - -instance (GSymOrd arity a) => GSymOrd arity (M1 i c a) where - gsymCompare args (M1 a) (M1 b) = gsymCompare args a b - {-# INLINE gsymCompare #-} - -instance (SymOrd a) => GSymOrd arity (K1 i a) where - gsymCompare _ (K1 a) (K1 b) = a `symCompare` b - {-# INLINE gsymCompare #-} - -instance GSymOrd Arity1 Par1 where - gsymCompare (SymOrdArgs1 c) (Par1 a) (Par1 b) = c a b - {-# INLINE gsymCompare #-} - -instance (SymOrd1 f) => GSymOrd Arity1 (Rec1 f) where - gsymCompare (SymOrdArgs1 c) (Rec1 a) (Rec1 b) = liftSymCompare c a b - {-# INLINE gsymCompare #-} - -instance (SymOrd1 f, GSymOrd Arity1 g) => GSymOrd Arity1 (f :.: g) where - gsymCompare targs (Comp1 a) (Comp1 b) = liftSymCompare (gsymCompare targs) a b - {-# INLINE gsymCompare #-} - -instance - (Generic a, GSymOrd Arity0 (Rep a), GSymEq Arity0 (Rep a)) => - SymOrd (Default a) - where - symCompare (Default l) (Default r) = genericSymCompare l r - {-# INLINE symCompare #-} - --- | Generic 'symCompare' function. -genericSymCompare :: (Generic a, GSymOrd Arity0 (Rep a)) => a -> a -> Union Ordering -genericSymCompare l r = gsymCompare SymOrdArgs0 (from l) (from r) -{-# INLINE genericSymCompare #-} - -instance - (Generic1 f, GSymOrd Arity1 (Rep1 f), GSymEq Arity1 (Rep1 f), SymOrd a) => - SymOrd (Default1 f a) - where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance - (Generic1 f, GSymOrd Arity1 (Rep1 f), GSymEq Arity1 (Rep1 f)) => - SymOrd1 (Default1 f) - where - liftSymCompare c (Default1 l) (Default1 r) = genericLiftSymCompare c l r - {-# INLINE liftSymCompare #-} - --- | Generic 'liftSymCompare' function. -genericLiftSymCompare :: - (Generic1 f, GSymOrd Arity1 (Rep1 f)) => - (a -> b -> Union Ordering) -> - f a -> - f b -> - Union Ordering -genericLiftSymCompare c l r = gsymCompare (SymOrdArgs1 c) (from1 l) (from1 r) -{-# INLINE genericLiftSymCompare #-} - -#define CONCRETE_SORD(type) \ -instance SymOrd type where \ - l .<= r = con $ l <= r; \ - l .< r = con $ l < r; \ - l .>= r = con $ l >= r; \ - l .> r = con $ l > r; \ - symCompare l r = mrgSingle $ compare l r; \ - {-# INLINE (.<=) #-}; \ - {-# INLINE (.<) #-}; \ - {-# INLINE (.>=) #-}; \ - {-# INLINE (.>) #-}; \ - {-# INLINE symCompare #-} - -#define CONCRETE_SORD_BV(type) \ -instance (KnownNat n, 1 <= n) => SymOrd (type n) where \ - l .<= r = con $ l <= r; \ - l .< r = con $ l < r; \ - l .>= r = con $ l >= r; \ - l .> r = con $ l > r; \ - symCompare l r = mrgSingle $ compare l r; \ - {-# INLINE (.<=) #-}; \ - {-# INLINE (.<) #-}; \ - {-# INLINE (.>=) #-}; \ - {-# INLINE (.>) #-}; \ - {-# INLINE symCompare #-} - -#if 1 -CONCRETE_SORD(Bool) -CONCRETE_SORD(Integer) -CONCRETE_SORD(Char) -CONCRETE_SORD(Int) -CONCRETE_SORD(Int8) -CONCRETE_SORD(Int16) -CONCRETE_SORD(Int32) -CONCRETE_SORD(Int64) -CONCRETE_SORD(Word) -CONCRETE_SORD(Word8) -CONCRETE_SORD(Word16) -CONCRETE_SORD(Word32) -CONCRETE_SORD(Word64) -CONCRETE_SORD(Float) -CONCRETE_SORD(Double) -CONCRETE_SORD(B.ByteString) -CONCRETE_SORD(T.Text) -CONCRETE_SORD(FPRoundingMode) -CONCRETE_SORD(Monoid.All) -CONCRETE_SORD(Monoid.Any) -CONCRETE_SORD(Ordering) -CONCRETE_SORD_BV(WordN) -CONCRETE_SORD_BV(IntN) -CONCRETE_SORD(AlgReal) -#endif - -instance (SymOrd a, Integral a) => SymOrd (Ratio a) where - a .<= b = numerator a * denominator b .<= numerator b * denominator a - {-# INLINE (.<=) #-} - a .< b = numerator a * denominator b .< numerator b * denominator a - {-# INLINE (.<) #-} - -instance (ValidFP eb sb) => SymOrd (FP eb sb) where - l .<= r = con $ l <= r - {-# INLINE (.<=) #-} - l .< r = con $ l < r - {-# INLINE (.<) #-} - l .>= r = con $ l >= r - {-# INLINE (.>=) #-} - l .> r = con $ l > r - {-# INLINE (.>) #-} - --- SymOrd -#define SORD_SIMPLE(symtype) \ -instance SymOrd symtype where \ - (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ - (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ - (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ - (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ - a `symCompare` b = mrgIf \ - (a .< b) \ - (mrgSingle LT) \ - (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)); \ - {-# INLINE (.<=) #-}; \ - {-# INLINE (.<) #-}; \ - {-# INLINE (.>=) #-}; \ - {-# INLINE (.>) #-}; \ - {-# INLINE symCompare #-} - -#define SORD_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SymOrd (symtype n) where \ - (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ - (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ - (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ - (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ - a `symCompare` b = mrgIf \ - (a .< b) \ - (mrgSingle LT) \ - (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)); \ - {-# INLINE (.<=) #-}; \ - {-# INLINE (.<) #-}; \ - {-# INLINE (.>=) #-}; \ - {-# INLINE (.>) #-}; \ - {-# INLINE symCompare #-} - -instance (ValidFP eb sb) => SymOrd (SymFP eb sb) where - (SymFP a) .<= (SymFP b) = SymBool $ pevalLeOrdTerm a b - {-# INLINE (.<=) #-} - (SymFP a) .< (SymFP b) = SymBool $ pevalLtOrdTerm a b - {-# INLINE (.<) #-} - (SymFP a) .>= (SymFP b) = SymBool $ pevalGeOrdTerm a b - {-# INLINE (.>=) #-} - (SymFP a) .> (SymFP b) = SymBool $ pevalGtOrdTerm a b - {-# INLINE (.>) #-} - -instance SymOrd SymBool where - l .<= r = symNot l .|| r - {-# INLINE (.<=) #-} - l .< r = symNot l .&& r - {-# INLINE (.<) #-} - l .>= r = l .|| symNot r - {-# INLINE (.>=) #-} - l .> r = l .&& symNot r - {-# INLINE (.>) #-} - symCompare l r = - mrgIf - (symNot l .&& r) - (mrgSingle LT) - (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) - {-# INLINE symCompare #-} - -#if 1 -SORD_SIMPLE(SymInteger) -SORD_SIMPLE(SymAlgReal) -SORD_SIMPLE(SymFPRoundingMode) -SORD_BV(SymIntN) -SORD_BV(SymWordN) -#endif - --- Union -instance (SymOrd a) => SymOrd (Union a) where - x .<= y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .<= y1 - x .< y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .< y1 - x .>= y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .>= y1 - x .> y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .> y1 - x `symCompare` y = tryMerge $ do - x1 <- x - y1 <- y - x1 `symCompare` y1 - -instance SymOrd1 Union where - liftSymCompare f x y = tryMerge $ do - x1 <- x - y1 <- y - f x1 y1 - --- Instances -deriveBuiltins - (ViaDefault ''SymOrd) - [''SymOrd] - [ ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last - ] - -deriveBuiltins - (ViaDefault1 ''SymOrd1) - [''SymOrd, ''SymOrd1] - [ ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last - ] - -symCompareSingleList :: (SymOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool -symCompareSingleList isLess isStrict = go - where - go [] [] = con (not isStrict) - go (x : xs) (y : ys) = - (if isLess then x .< y else x .> y) .|| (x .== y .&& go xs ys) - go [] _ = if isLess then con True else con False - go _ [] = if isLess then con False else con True - -symLiftCompareList :: - (a -> b -> Union Ordering) -> [a] -> [b] -> Union Ordering -symLiftCompareList _ [] [] = mrgSingle EQ -symLiftCompareList f (x : xs) (y : ys) = do - oxy <- f x y - case oxy of - LT -> mrgSingle LT - EQ -> symLiftCompareList f xs ys - GT -> mrgSingle GT -symLiftCompareList _ [] _ = mrgSingle LT -symLiftCompareList _ _ [] = mrgSingle GT - --- [] -instance (SymOrd a) => SymOrd [a] where - {-# INLINE (.<=) #-} - {-# INLINE (.<) #-} - {-# INLINE symCompare #-} - {-# INLINE (.>=) #-} - {-# INLINE (.>) #-} - (.<=) = symCompareSingleList True False - (.<) = symCompareSingleList True True - (.>=) = symCompareSingleList False False - (.>) = symCompareSingleList False True - symCompare = symLiftCompareList symCompare - -instance SymOrd1 [] where - liftSymCompare = symLiftCompareList - {-# INLINE liftSymCompare #-} - --- ExceptT -instance (SymOrd1 m, SymOrd e, SymOrd a) => SymOrd (ExceptT e m a) where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance (SymOrd1 m, SymOrd e) => SymOrd1 (ExceptT e m) where - liftSymCompare f (ExceptT l) (ExceptT r) = - liftSymCompare (liftSymCompare f) l r - {-# INLINE liftSymCompare #-} - --- MaybeT -instance (SymOrd1 m, SymOrd a) => SymOrd (MaybeT m a) where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance (SymOrd1 m) => SymOrd1 (MaybeT m) where - liftSymCompare f (MaybeT l) (MaybeT r) = liftSymCompare (liftSymCompare f) l r - {-# INLINE liftSymCompare #-} - --- Writer -instance (SymOrd1 m, SymOrd w, SymOrd a) => SymOrd (WriterLazy.WriterT w m a) where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance (SymOrd1 m, SymOrd w) => SymOrd1 (WriterLazy.WriterT w m) where - liftSymCompare f (WriterLazy.WriterT l) (WriterLazy.WriterT r) = - liftSymCompare (liftSymCompare2 f symCompare) l r - {-# INLINE liftSymCompare #-} - -instance (SymOrd1 m, SymOrd w, SymOrd a) => SymOrd (WriterStrict.WriterT w m a) where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance (SymOrd1 m, SymOrd w) => SymOrd1 (WriterStrict.WriterT w m) where - liftSymCompare f (WriterStrict.WriterT l) (WriterStrict.WriterT r) = - liftSymCompare (liftSymCompare2 f symCompare) l r - {-# INLINE liftSymCompare #-} - --- IdentityT -instance (SymOrd1 m, SymOrd a) => SymOrd (IdentityT m a) where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance (SymOrd1 m) => SymOrd1 (IdentityT m) where - liftSymCompare f (IdentityT l) (IdentityT r) = liftSymCompare f l r - {-# INLINE liftSymCompare #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (SymOrd (l a), SymOrd (r a)) => SymOrd (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (SymOrd1 l, SymOrd1 r) => SymOrd1 (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (SymOrd (l a), SymOrd (r a)) => SymOrd (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (SymOrd1 l, SymOrd1 r) => SymOrd1 (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (SymOrd (f (g a))) => SymOrd (Compose f g a) - -instance (SymOrd1 f, SymOrd1 g) => SymOrd1 (Compose f g) where - liftSymCompare f (Compose l) (Compose r) = - liftSymCompare (liftSymCompare f) l r - --- Const -deriving via (Default (Const a b)) instance (SymOrd a) => SymOrd (Const a b) - -deriving via (Default1 (Const a)) instance (SymOrd a) => SymOrd1 (Const a) - --- Alt -deriving via (Default (Alt f a)) instance (SymOrd (f a)) => SymOrd (Alt f a) - -deriving via (Default1 (Alt f)) instance (SymOrd1 f) => SymOrd1 (Alt f) - --- Ap -deriving via (Default (Ap f a)) instance (SymOrd (f a)) => SymOrd (Ap f a) - -deriving via (Default1 (Ap f)) instance (SymOrd1 f) => SymOrd1 (Ap f) - --- Generic -deriving via (Default (U1 p)) instance SymOrd (U1 p) - -deriving via (Default (V1 p)) instance SymOrd (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (SymOrd c) => SymOrd (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (SymOrd (f p)) => SymOrd (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (SymOrd (f p), SymOrd (g p)) => SymOrd ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (SymOrd (f p), SymOrd (g p)) => SymOrd ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (SymOrd p) => SymOrd (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (SymOrd (f p)) => SymOrd (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (SymOrd (f (g p))) => SymOrd ((f :.: g) p) - --- Down -instance (SymOrd a) => SymOrd (Down a) where - symCompare = symCompare1 - {-# INLINE symCompare #-} - -instance SymOrd1 Down where - liftSymCompare comp (Down l) (Down r) = do - res <- comp l r - case res of - LT -> mrgSingle GT - EQ -> mrgSingle EQ - GT -> mrgSingle LT - {-# INLINE liftSymCompare #-} - -instance SymOrd2 Either where - liftSymCompare2 f _ (Left l) (Left r) = f l r - liftSymCompare2 _ g (Right l) (Right r) = g l r - liftSymCompare2 _ _ (Left _) (Right _) = mrgSingle LT - liftSymCompare2 _ _ (Right _) (Left _) = mrgSingle GT - {-# INLINE liftSymCompare2 #-} - -instance SymOrd2 (,) where - liftSymCompare2 f g (a1, b1) (a2, b2) = do - ma <- f a1 a2 - mb <- g b1 b2 - mrgSingle $ ma <> mb - {-# INLINE liftSymCompare2 #-} - -instance (SymOrd a) => SymOrd2 ((,,) a) where - liftSymCompare2 f g (a1, b1, c1) (a2, b2, c2) = do - ma <- symCompare a1 a2 - mb <- f b1 b2 - mc <- g c1 c2 - mrgSingle $ ma <> mb <> mc - {-# INLINE liftSymCompare2 #-} - -instance (SymOrd a, SymOrd b) => SymOrd2 ((,,,) a b) where - liftSymCompare2 f g (a1, b1, c1, d1) (a2, b2, c2, d2) = do - ma <- symCompare a1 a2 - mb <- symCompare b1 b2 - mc <- f c1 c2 - md <- g d1 d2 - mrgSingle $ ma <> mb <> mc <> md - {-# INLINE liftSymCompare2 #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd +import Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd () diff --git a/src/Grisette/Internal/Core/Data/Class/ToCon.hs b/src/Grisette/Internal/Core/Data/Class/ToCon.hs --- a/src/Grisette/Internal/Core/Data/Class/ToCon.hs +++ b/src/Grisette/Internal/Core/Data/Class/ToCon.hs @@ -1,24 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.ToCon --- 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 @@ -40,649 +24,5 @@ ) 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.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator, (%)) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1 (U1), - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving (Default (Default), Default1 (Default1)) -import Generics.Deriving.Instances () -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Class.BitCast (bitCastOrCanonical) -import Grisette.Internal.Core.Data.Class.Solvable - ( Solvable (conView), - pattern Con, - ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal (AlgExactRational)) -import Grisette.Internal.SymPrim.BV - ( IntN (IntN), - WordN (WordN), - ) -import Grisette.Internal.SymPrim.FP - ( FP, - FP32, - FP64, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) -import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN, - SymWordN, - ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP - ( SymFP, - SymFP32, - SymFP64, - SymFPRoundingMode, - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | Convert a symbolic value to concrete value if possible. -class ToCon a b where - -- | Convert a symbolic value to concrete value if possible. - -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'. - -- - -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer - -- Nothing - -- - -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer - -- Just 1 - -- - -- 'toCon' works on complex types too. - -- - -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer] - -- Just [1,2] - -- - -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer] - -- Nothing - toCon :: a -> Maybe b - -instance {-# INCOHERENT #-} ToCon v v where - toCon = Just - --- | Lifting of 'ToCon' to unary type constructors. -class (forall a b. (ToCon a b) => ToCon (f1 a) (f2 b)) => ToCon1 f1 f2 where - -- | Lift a conversion to concrete function to unary type constructors. - liftToCon :: (a -> Maybe b) -> f1 a -> Maybe (f2 b) - --- | Lift the standard 'toCon' to unary type constructors. -toCon1 :: (ToCon1 f1 f2, ToCon a b) => f1 a -> Maybe (f2 b) -toCon1 = liftToCon toCon -{-# INLINE toCon1 #-} - --- | Lifting of 'ToCon' to binary type constructors. -class (forall a b. (ToCon a b) => ToCon1 (f1 a) (f2 b)) => ToCon2 f1 f2 where - -- | Lift conversion to concrete functions to binary type constructors. - liftToCon2 :: (a -> Maybe b) -> (c -> Maybe d) -> f1 a c -> Maybe (f2 b d) - --- | Lift the standard 'toCon' to binary type constructors. -toCon2 :: (ToCon2 f1 f2, ToCon a b, ToCon c d) => f1 a c -> Maybe (f2 b d) -toCon2 = liftToCon2 toCon toCon -{-# INLINE toCon2 #-} - --- Derivations - --- | The arguments to the generic 'toCon' function. -data family ToConArgs arity a b :: Type - -data instance ToConArgs Arity0 _ _ = ToConArgs0 - -newtype instance ToConArgs Arity1 a b - = ToConArgs1 (a -> Maybe b) - --- | The class of types that can be generically converted to concrete values. -class GToCon arity f1 f2 where - gtoCon :: ToConArgs arity a b -> f1 a -> Maybe (f2 b) - -instance GToCon arity V1 V1 where - gtoCon _ _ = error "Impossible" - {-# INLINE gtoCon #-} - -instance GToCon arity U1 U1 where - gtoCon _ _ = Just U1 - {-# INLINE gtoCon #-} - -instance - (GToCon arity a b, GToCon arity c d) => - GToCon arity (a :*: c) (b :*: d) - where - gtoCon args (a :*: c) = do - a' <- gtoCon args a - c' <- gtoCon args c - return $ a' :*: c' - {-# INLINE gtoCon #-} - -instance - (GToCon arity a b, GToCon arity c d) => - GToCon arity (a :+: c) (b :+: d) - where - gtoCon args (L1 a) = L1 <$> gtoCon args a - gtoCon args (R1 a) = R1 <$> gtoCon args a - {-# INLINE gtoCon #-} - -instance (GToCon arity a b) => GToCon arity (M1 i c1 a) (M1 i c2 b) where - gtoCon args (M1 a) = M1 <$> gtoCon args a - {-# INLINE gtoCon #-} - -instance (ToCon a b) => GToCon arity (K1 i a) (K1 i b) where - gtoCon _ (K1 a) = K1 <$> toCon a - {-# INLINE gtoCon #-} - -instance GToCon Arity1 Par1 Par1 where - gtoCon (ToConArgs1 f) (Par1 a) = Par1 <$> f a - {-# INLINE gtoCon #-} - -instance (ToCon1 f1 f2) => GToCon Arity1 (Rec1 f1) (Rec1 f2) where - gtoCon (ToConArgs1 f) (Rec1 a) = Rec1 <$> liftToCon f a - {-# INLINE gtoCon #-} - -instance - (ToCon1 f1 f2, GToCon Arity1 g1 g2) => - GToCon Arity1 (f1 :.: g1) (f2 :.: g2) - where - gtoCon targs (Comp1 a) = Comp1 <$> liftToCon (gtoCon targs) a - {-# INLINE gtoCon #-} - --- | Generic 'toCon' function. -genericToCon :: - (Generic a, Generic b, GToCon Arity0 (Rep a) (Rep b)) => - a -> - Maybe b -genericToCon = fmap to . gtoCon ToConArgs0 . from -{-# INLINE genericToCon #-} - --- | Generic 'liftToCon' function. -genericLiftToCon :: - (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2)) => - (a -> Maybe b) -> - f1 a -> - Maybe (f2 b) -genericLiftToCon f = fmap to1 . gtoCon (ToConArgs1 f) . from1 -{-# INLINE genericLiftToCon #-} - -instance - (Generic a, Generic b, GToCon Arity0 (Rep a) (Rep b)) => - ToCon a (Default b) - where - toCon = fmap Default . genericToCon - {-# INLINE toCon #-} - -instance - (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2), ToCon a b) => - ToCon (f1 a) (Default1 f2 b) - where - toCon = toCon1 - -instance - (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2)) => - ToCon1 f1 (Default1 f2) - where - liftToCon f = fmap Default1 . genericLiftToCon f - {-# INLINE liftToCon #-} - -#define CONCRETE_TOCON(type) \ -instance ToCon type type where \ - toCon = Just - -#define CONCRETE_TOCON_BV(type) \ -instance (KnownNat n, 1 <= n) => ToCon (type n) (type n) where \ - toCon = Just - -#if 1 -CONCRETE_TOCON(Bool) -CONCRETE_TOCON(Integer) -CONCRETE_TOCON(Char) -CONCRETE_TOCON(Int) -CONCRETE_TOCON(Int8) -CONCRETE_TOCON(Int16) -CONCRETE_TOCON(Int32) -CONCRETE_TOCON(Int64) -CONCRETE_TOCON(Word) -CONCRETE_TOCON(Word8) -CONCRETE_TOCON(Word16) -CONCRETE_TOCON(Word32) -CONCRETE_TOCON(Word64) -CONCRETE_TOCON(Float) -CONCRETE_TOCON(Double) -CONCRETE_TOCON(B.ByteString) -CONCRETE_TOCON(T.Text) -CONCRETE_TOCON_BV(WordN) -CONCRETE_TOCON_BV(IntN) -CONCRETE_TOCON(FPRoundingMode) -CONCRETE_TOCON(Monoid.All) -CONCRETE_TOCON(Monoid.Any) -CONCRETE_TOCON(Ordering) -#endif - -instance (ValidFP eb sb) => ToCon (FP eb sb) (FP eb sb) where - toCon = Just - -instance ToCon (a =-> b) (a =-> b) where - toCon = Just - -instance ToCon (a --> b) (a --> b) where - toCon = Just - -#define TO_CON_SYMID_SIMPLE(symtype) \ -instance ToCon symtype symtype where \ - toCon = Just - -#define TO_CON_SYMID_BV(symtype) \ -instance ToCon (symtype n) (symtype n) where \ - toCon = Just - -#define TO_CON_SYMID_FUN(op) \ -instance ToCon (a op b) (a op b) where \ - toCon = Just - -#if 1 -TO_CON_SYMID_SIMPLE(SymBool) -TO_CON_SYMID_SIMPLE(SymInteger) -TO_CON_SYMID_SIMPLE(SymAlgReal) -TO_CON_SYMID_BV(SymIntN) -TO_CON_SYMID_BV(SymWordN) -TO_CON_SYMID_FUN(=~>) -TO_CON_SYMID_FUN(-~>) -TO_CON_SYMID_SIMPLE(SymFPRoundingMode) -#endif - -instance (ValidFP eb sb) => ToCon (SymFP eb sb) (SymFP eb sb) where - toCon = Just - -#define TO_CON_FROMSYM_SIMPLE(contype, symtype) \ -instance ToCon symtype contype where \ - toCon = conView - -#define TO_CON_FROMSYM_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \ - toCon = conView - -#define TO_CON_FROMSYM_FUN(conop, symop, consop) \ -instance (LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \ - toCon a@(consop _) = conView a - -#if 1 -TO_CON_FROMSYM_SIMPLE(Bool, SymBool) -TO_CON_FROMSYM_SIMPLE(Integer, SymInteger) -TO_CON_FROMSYM_SIMPLE(AlgReal, SymAlgReal) -TO_CON_FROMSYM_BV(IntN, SymIntN) -TO_CON_FROMSYM_BV(WordN, SymWordN) -TO_CON_FROMSYM_FUN((=->), (=~>), SymTabularFun) -TO_CON_FROMSYM_FUN((-->), (-~>), SymGeneralFun) -TO_CON_FROMSYM_SIMPLE(FPRoundingMode, SymFPRoundingMode) -#endif - -instance (ValidFP eb sb) => ToCon (SymFP eb sb) (FP eb sb) where - toCon = conView - -#define TOCON_MACHINE_INTEGER(sbvw, bvw, n, int) \ -instance ToCon (sbvw n) int where \ - toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \ - toCon _ = Nothing - -#if 1 -TOCON_MACHINE_INTEGER(SymIntN, IntN, 8, Int8) -TOCON_MACHINE_INTEGER(SymIntN, IntN, 16, Int16) -TOCON_MACHINE_INTEGER(SymIntN, IntN, 32, Int32) -TOCON_MACHINE_INTEGER(SymIntN, IntN, 64, Int64) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 8, Word8) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 16, Word16) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 32, Word32) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 64, Word64) -TOCON_MACHINE_INTEGER(SymIntN, IntN, $intBitwidthQ, Int) -TOCON_MACHINE_INTEGER(SymWordN, WordN, $intBitwidthQ, Word) -#endif - -instance ToCon SymFP32 Float where - toCon (Con (fp :: FP32)) = Just $ bitCastOrCanonical fp - toCon _ = Nothing - -instance ToCon SymFP64 Double where - toCon (Con (fp :: FP64)) = Just $ bitCastOrCanonical fp - toCon _ = Nothing - -instance (ToCon a b, Integral b) => ToCon (Ratio a) (Ratio b) where - toCon r = do - n <- toCon (numerator r) - d <- toCon (denominator r) - return $ n % d - -instance ToCon SymAlgReal Rational where - toCon (Con (x :: AlgReal)) = - case x of - AlgExactRational r -> Just r - _ -> Nothing - toCon _ = Nothing - -deriveBuiltins - (ViaDefault ''ToCon) - [''ToCon] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''ToCon1) - [''ToCon, ''ToCon1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- ExceptT -instance - (ToCon1 m1 m2, ToCon e1 e2, ToCon a b) => - ToCon (ExceptT e1 m1 a) (ExceptT e2 m2 b) - where - toCon = toCon1 - {-# INLINE toCon #-} - -instance - (ToCon1 m1 m2, ToCon e1 e2) => - ToCon1 (ExceptT e1 m1) (ExceptT e2 m2) - where - liftToCon f (ExceptT v) = ExceptT <$> liftToCon (liftToCon f) v - {-# INLINE liftToCon #-} - --- MaybeT -instance - (ToCon1 m1 m2, ToCon a b) => - ToCon (MaybeT m1 a) (MaybeT m2 b) - where - toCon = toCon1 - {-# INLINE toCon #-} - -instance - (ToCon1 m1 m2) => - ToCon1 (MaybeT m1) (MaybeT m2) - where - liftToCon f (MaybeT v) = MaybeT <$> liftToCon (liftToCon f) v - {-# INLINE liftToCon #-} - --- WriterT -instance - (ToCon1 m1 m2, ToCon a b, ToCon s1 s2) => - ToCon (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) - where - toCon (WriterLazy.WriterT v) = WriterLazy.WriterT <$> toCon v - -instance - (ToCon1 m1 m2, ToCon s1 s2) => - ToCon1 (WriterLazy.WriterT s1 m1) (WriterLazy.WriterT s2 m2) - where - liftToCon f (WriterLazy.WriterT v) = - WriterLazy.WriterT <$> liftToCon (liftToCon2 f toCon) v - -instance - (ToCon1 m1 m2, ToCon a b, ToCon s1 s2) => - ToCon (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) - where - toCon (WriterStrict.WriterT v) = WriterStrict.WriterT <$> toCon v - -instance - (ToCon1 m1 m2, ToCon s1 s2) => - ToCon1 (WriterStrict.WriterT s1 m1) (WriterStrict.WriterT s2 m2) - where - liftToCon f (WriterStrict.WriterT v) = - WriterStrict.WriterT <$> liftToCon (liftToCon2 f toCon) v - --- IdentityT -instance - (ToCon1 m m1, ToCon a b) => - ToCon (IdentityT m a) (IdentityT m1 b) - where - toCon = toCon1 - {-# INLINE toCon #-} - -instance - (ToCon1 m m1) => - ToCon1 (IdentityT m) (IdentityT m1) - where - liftToCon f (IdentityT a) = IdentityT <$> liftToCon f a - {-# INLINE liftToCon #-} - --- Identity -instance {-# INCOHERENT #-} (ToCon a b) => ToCon (Identity a) (Identity b) where - toCon = toCon1 - -instance {-# INCOHERENT #-} (ToCon a b) => ToCon (Identity a) b where - toCon = toCon . runIdentity - -instance {-# INCOHERENT #-} (ToCon a b) => ToCon a (Identity b) where - toCon = fmap Identity . toCon - -instance ToCon1 Identity Identity where - liftToCon f (Identity a) = Identity <$> f a - --- Special -instance - (ToCon (m1 (Either e1 a)) (Either e2 b)) => - ToCon (ExceptT e1 m1 a) (Either e2 b) - where - toCon (ExceptT v) = toCon v - --- Product -deriving via - (Default (Product l r a)) - instance - (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) => - ToCon (Product l0 r0 a0) (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Product l0 r0) (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) => - ToCon (Sum l0 r0 a0) (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Sum l0 r0) (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (ToCon (f0 (g0 a0)) (f (g a))) => ToCon (Compose f0 g0 a0) (Compose f g a) - -instance - (ToCon1 f0 f, ToCon1 g0 g) => - ToCon1 (Compose f0 g0) (Compose f g) - where - liftToCon f (Compose a) = Compose <$> liftToCon (liftToCon f) a - {-# INLINE liftToCon #-} - --- Const -deriving via - (Default (Const a b)) - instance - (ToCon a0 a) => ToCon (Const a0 b0) (Const a b) - -deriving via - (Default1 (Const a)) - instance - (ToCon a0 a) => ToCon1 (Const a0) (Const a) - --- Alt -deriving via - (Default (Alt f a)) - instance - (ToCon (f0 a0) (f a)) => ToCon (Alt f0 a0) (Alt f a) - -deriving via - (Default1 (Alt f)) - instance - (ToCon1 f0 f) => ToCon1 (Alt f0) (Alt f) - --- Ap -deriving via - (Default (Ap f a)) - instance - (ToCon (f0 a0) (f a)) => ToCon (Ap f0 a0) (Ap f a) - -deriving via - (Default1 (Ap f)) - instance - (ToCon1 f0 f) => ToCon1 (Ap f0) (Ap f) - --- Generic -deriving via (Default (U1 p)) instance ToCon (U1 p0) (U1 p) - -deriving via (Default (V1 p)) instance ToCon (V1 p0) (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (ToCon c0 c) => ToCon (K1 i0 c0 p0) (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (ToCon (f0 p0) (f p)) => ToCon (M1 i0 c0 f0 p0) (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (ToCon (f0 p0) (f p), ToCon (g0 p0) (g p)) => - ToCon ((f0 :+: g0) p0) ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (ToCon (f0 p0) (f p), ToCon (g0 p0) (g p)) => - ToCon ((f0 :*: g0) p0) ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (ToCon p0 p) => ToCon (Par1 p0) (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (ToCon (f0 p0) (f p)) => ToCon (Rec1 f0 p0) (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (ToCon (f0 (g0 p0)) (f (g p))) => ToCon ((f0 :.: g0) p0) ((f :.: g) p) - --- ToCon2 -instance ToCon2 Either Either where - liftToCon2 f _ (Left a) = Left <$> f a - liftToCon2 _ g (Right b) = Right <$> g b - {-# INLINE liftToCon2 #-} - -instance ToCon2 (,) (,) where - liftToCon2 f g (a, b) = (,) <$> f a <*> g b - {-# INLINE liftToCon2 #-} - -instance (ToCon a b) => ToCon2 ((,,) a) ((,,) b) where - liftToCon2 f g (a, b, c) = (,,) <$> toCon a <*> f b <*> g c - {-# INLINE liftToCon2 #-} - -instance (ToCon a c, ToCon b d) => ToCon2 ((,,,) a b) ((,,,) c d) where - liftToCon2 f g (a, b, c, d) = (,,,) <$> toCon a <*> toCon b <*> f c <*> g d - {-# INLINE liftToCon2 #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon +import Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon () diff --git a/src/Grisette/Internal/Core/Data/Class/ToSym.hs b/src/Grisette/Internal/Core/Data/Class/ToSym.hs --- a/src/Grisette/Internal/Core/Data/Class/ToSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/ToSym.hs @@ -1,21 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.ToSym @@ -41,730 +24,5 @@ ) where -import Control.Monad.Identity - ( Identity (Identity, runIdentity), - IdentityT (IdentityT), - ) -import Control.Monad.Reader (ReaderT (ReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Except (ExceptT (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.Compose (Compose (Compose)) -import Data.Functor.Const (Const) -import Data.Functor.Product (Product) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import Data.Monoid (Alt, Ap) -import qualified Data.Monoid as Monoid -import Data.Ord (Down) -import Data.Ratio (Ratio, denominator, numerator, (%)) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Default1 (Default1), - Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1 (U1), - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast)) -import Grisette.Internal.Core.Data.Class.Mergeable - ( GMergeable, - Mergeable, - Mergeable1, - Mergeable2, - resolveMergeable1, - ) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV - ( IntN, - WordN, - ) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedNonFuncPrim, - SupportedPrim, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN, - SymWordN, - ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP - ( SymFP, - SymFP32, - SymFP64, - SymFPRoundingMode, - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.SymPrim - --- | Convert a concrete value to symbolic value. -class (Mergeable b) => ToSym a b where - -- | Convert a concrete value to symbolic value. - -- - -- >>> toSym False :: SymBool - -- false - -- - -- >>> toSym [False, True] :: [SymBool] - -- [false,true] - toSym :: a -> b - -instance {-# INCOHERENT #-} (Mergeable a) => ToSym a a where - toSym = id - {-# INLINE toSym #-} - --- | Lifting of 'ToSym' to unary type constructors. -class - (forall a b. (ToSym a b) => ToSym (f1 a) (f2 b), Mergeable1 f2) => - ToSym1 f1 f2 - where - -- | Lift a conversion to symbolic function to unary type constructors. - liftToSym :: (Mergeable b) => (a -> b) -> f1 a -> f2 b - --- | Lift the standard 'toSym' to unary type constructors. -toSym1 :: (ToSym1 f1 f2, ToSym a b) => f1 a -> f2 b -toSym1 = liftToSym toSym -{-# INLINE toSym1 #-} - --- | Lifting of 'ToSym' to binary type constructors. -class - (forall a b. (ToSym a b) => ToSym1 (f1 a) (f2 b), Mergeable2 f2) => - ToSym2 f1 f2 - where - -- | Lift conversion to symbolic functions to binary type constructors. - liftToSym2 :: (a -> b) -> (c -> d) -> f1 a c -> f2 b d - --- | Lift the standard 'toSym' to binary type constructors. -toSym2 :: (ToSym2 f1 f2, ToSym a b, ToSym c d) => f1 a c -> f2 b d -toSym2 = liftToSym2 toSym toSym -{-# INLINE toSym2 #-} - --- Derivations - --- | The arguments to the generic 'toSym' function. -data family ToSymArgs arity a b :: Type - -data instance ToSymArgs Arity0 _ _ = ToSymArgs0 - -data instance ToSymArgs Arity1 _ _ where - ToSymArgs1 :: (Mergeable b) => (a -> b) -> ToSymArgs Arity1 a b - --- | The class of types that can be generically converted to symbolic values. -class GToSym arity f1 f2 where - gtoSym :: ToSymArgs arity a b -> f1 a -> f2 b - -instance GToSym arity V1 V1 where - gtoSym _ _ = error "Impossible" - {-# INLINE gtoSym #-} - -instance GToSym arity U1 U1 where - gtoSym _ _ = U1 - {-# INLINE gtoSym #-} - -instance - (GToSym arity a b, GToSym arity c d) => - GToSym arity (a :+: c) (b :+: d) - where - gtoSym args (L1 a) = L1 $ gtoSym args a - gtoSym args (R1 b) = R1 $ gtoSym args b - {-# INLINE gtoSym #-} - -instance - (GToSym arity a b, GToSym arity c d) => - GToSym arity (a :*: c) (b :*: d) - where - gtoSym args (a :*: c) = gtoSym args a :*: gtoSym args c - {-# INLINE gtoSym #-} - -instance (ToSym a b) => GToSym arity (K1 i a) (K1 i b) where - gtoSym _ (K1 a) = K1 $ toSym a - {-# INLINE gtoSym #-} - -instance (GToSym arity f1 f2) => GToSym arity (M1 i c1 f1) (M1 i c2 f2) where - gtoSym args (M1 a) = M1 $ gtoSym args a - {-# INLINE gtoSym #-} - -instance GToSym Arity1 Par1 Par1 where - gtoSym (ToSymArgs1 f) (Par1 a) = Par1 $ f a - {-# INLINE gtoSym #-} - -instance (ToSym1 f1 f2) => GToSym Arity1 (Rec1 f1) (Rec1 f2) where - gtoSym (ToSymArgs1 f) (Rec1 a) = Rec1 $ liftToSym f a - {-# INLINE gtoSym #-} - -instance - (ToSym1 f1 f2, GToSym Arity1 g1 g2, Mergeable1 g2) => - GToSym Arity1 (f1 :.: g1) (f2 :.: g2) - where - gtoSym targs@ToSymArgs1 {} (Comp1 a) = Comp1 $ liftToSym (gtoSym targs) a - {-# INLINE gtoSym #-} - --- | Generic 'toSym' function. -genericToSym :: - (Generic a, Generic b, GToSym Arity0 (Rep a) (Rep b)) => - a -> - b -genericToSym = to . gtoSym ToSymArgs0 . from -{-# INLINE genericToSym #-} - --- | Generic 'liftToSym' function. -genericLiftToSym :: - (Generic1 f1, Generic1 f2, GToSym Arity1 (Rep1 f1) (Rep1 f2), Mergeable b) => - (a -> b) -> - f1 a -> - f2 b -genericLiftToSym f = to1 . gtoSym (ToSymArgs1 f) . from1 -{-# INLINE genericLiftToSym #-} - -instance - ( Generic a, - Generic b, - GToSym Arity0 (Rep a) (Rep b), - GMergeable Arity0 (Rep b) - ) => - ToSym a (Default b) - where - toSym = Default . genericToSym - {-# INLINE toSym #-} - -instance - ( Generic1 f1, - Generic1 f2, - GToSym Arity1 (Rep1 f1) (Rep1 f2), - ToSym a b, - GMergeable Arity1 (Rep1 f2) - ) => - ToSym (f1 a) (Default1 f2 b) - where - toSym = toSym1 - -instance - ( Generic1 f1, - Generic1 f2, - GToSym Arity1 (Rep1 f1) (Rep1 f2), - GMergeable Arity1 (Rep1 f2) - ) => - ToSym1 f1 (Default1 f2) - where - liftToSym f = Default1 . genericLiftToSym f - {-# INLINE liftToSym #-} - -#define CONCRETE_TOSYM(type) \ -instance ToSym type type where \ - toSym = id - -#define CONCRETE_TOSYM_BV(type) \ -instance (KnownNat n, 1 <= n) => ToSym (type n) (type n) where \ - toSym = id - -#if 1 -CONCRETE_TOSYM(Bool) -CONCRETE_TOSYM(Integer) -CONCRETE_TOSYM(Char) -CONCRETE_TOSYM(Int) -CONCRETE_TOSYM(Int8) -CONCRETE_TOSYM(Int16) -CONCRETE_TOSYM(Int32) -CONCRETE_TOSYM(Int64) -CONCRETE_TOSYM(Word) -CONCRETE_TOSYM(Word8) -CONCRETE_TOSYM(Word16) -CONCRETE_TOSYM(Word32) -CONCRETE_TOSYM(Word64) -CONCRETE_TOSYM(Float) -CONCRETE_TOSYM(Double) -CONCRETE_TOSYM(B.ByteString) -CONCRETE_TOSYM(T.Text) -CONCRETE_TOSYM(FPRoundingMode) -CONCRETE_TOSYM_BV(IntN) -CONCRETE_TOSYM_BV(WordN) -CONCRETE_TOSYM(Monoid.All) -CONCRETE_TOSYM(Monoid.Any) -CONCRETE_TOSYM(Ordering) -#endif - -instance (ValidFP eb sb) => ToSym (FP eb sb) (FP eb sb) where - toSym = id - -instance ToSym (a =-> b) (a =-> b) where - toSym = id - -instance ToSym (a --> b) (a --> b) where - toSym = id - -#define TO_SYM_SYMID_SIMPLE(symtype) \ -instance ToSym symtype symtype where \ - toSym = id - -#define TO_SYM_SYMID_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ToSym (symtype n) (symtype n) where \ - toSym = id - -#define TO_SYM_SYMID_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - ToSym (op sa sb) (op sa sb) where \ - toSym = id - -#if 1 -TO_SYM_SYMID_SIMPLE(SymBool) -TO_SYM_SYMID_SIMPLE(SymInteger) -TO_SYM_SYMID_SIMPLE(SymAlgReal) -TO_SYM_SYMID_BV(SymIntN) -TO_SYM_SYMID_BV(SymWordN) -TO_SYM_SYMID_FUN((=->), (=~>)) -TO_SYM_SYMID_FUN((-->), (-~>)) -TO_SYM_SYMID_SIMPLE(SymFPRoundingMode) -#endif - -instance (ValidFP eb sb) => ToSym (SymFP eb sb) (SymFP eb sb) where - toSym = id - -#define TO_SYM_FROMCON_SIMPLE(contype, symtype) \ -instance ToSym contype symtype where \ - toSym = con - -#define TO_SYM_FROMCON_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => ToSym (contype n) (symtype n) where \ - toSym = con - -#define TO_SYM_FROMCON_FUN(conop, symop) \ -instance (SupportedPrim (conop ca cb), SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb) => \ - ToSym (conop ca cb) (symop sa sb) where \ - toSym = con - -#if 1 -TO_SYM_FROMCON_SIMPLE(Bool, SymBool) -TO_SYM_FROMCON_SIMPLE(Integer, SymInteger) -TO_SYM_FROMCON_SIMPLE(AlgReal, SymAlgReal) -TO_SYM_FROMCON_BV(IntN, SymIntN) -TO_SYM_FROMCON_BV(WordN, SymWordN) -TO_SYM_FROMCON_FUN((=->), (=~>)) -TO_SYM_FROMCON_FUN((-->), (-~>)) -TO_SYM_FROMCON_SIMPLE(FPRoundingMode, SymFPRoundingMode) -#endif - -instance (ValidFP eb sb) => ToSym (FP eb sb) (SymFP eb sb) where - toSym = con - -#define TOSYM_MACHINE_INTEGER(int, bv) \ -instance ToSym int (bv) where \ - toSym = fromIntegral - -#if 1 -TOSYM_MACHINE_INTEGER(Int8, SymIntN 8) -TOSYM_MACHINE_INTEGER(Int16, SymIntN 16) -TOSYM_MACHINE_INTEGER(Int32, SymIntN 32) -TOSYM_MACHINE_INTEGER(Int64, SymIntN 64) -TOSYM_MACHINE_INTEGER(Word8, SymWordN 8) -TOSYM_MACHINE_INTEGER(Word16, SymWordN 16) -TOSYM_MACHINE_INTEGER(Word32, SymWordN 32) -TOSYM_MACHINE_INTEGER(Word64, SymWordN 64) -TOSYM_MACHINE_INTEGER(Int, SymIntN $intBitwidthQ) -TOSYM_MACHINE_INTEGER(Word, SymWordN $intBitwidthQ) -#endif - -instance ToSym Float SymFP32 where - toSym = con . bitCast - {-# INLINE toSym #-} - -instance ToSym Double SymFP64 where - toSym = con . bitCast - {-# INLINE toSym #-} - -instance - (Integral b, Typeable b, Show b, ToSym a b) => - ToSym (Ratio a) (Ratio b) - where - toSym r = toSym (numerator r) % toSym (denominator r) - {-# INLINE toSym #-} - -instance ToSym Rational SymAlgReal where - toSym v = con (fromRational v) - -deriveBuiltins - (ViaDefault ''ToSym) - [''ToSym] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''NotRepresentableFPError, - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - -deriveBuiltins - (ViaDefault1 ''ToSym1) - [''ToSym, ''ToSym1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Monoid.Dual, - ''Monoid.Sum, - ''Monoid.Product, - ''Monoid.First, - ''Monoid.Last, - ''Down - ] - --- ExceptT -instance - (ToSym1 m1 m2, ToSym e1 e2, ToSym a b) => - ToSym (ExceptT e1 m1 a) (ExceptT e2 m2 b) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym1 m1 m2, ToSym e1 e2) => - ToSym1 (ExceptT e1 m1) (ExceptT e2 m2) - where - liftToSym f (ExceptT v) = ExceptT $ liftToSym (liftToSym f) v - {-# INLINE liftToSym #-} - --- MaybeT -instance - (ToSym1 m1 m2, ToSym a b) => - ToSym (MaybeT m1 a) (MaybeT m2 b) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym1 m1 m2) => - ToSym1 (MaybeT m1) (MaybeT m2) - where - liftToSym f (MaybeT v) = MaybeT $ liftToSym (liftToSym f) v - {-# INLINE liftToSym #-} - --- WriterT -instance - (ToSym1 m1 m2, ToSym a b, ToSym s1 s2) => - ToSym (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym1 m1 m2, ToSym s1 s2) => - ToSym1 (WriterLazy.WriterT s1 m1) (WriterLazy.WriterT s2 m2) - where - liftToSym f (WriterLazy.WriterT v) = - WriterLazy.WriterT $ liftToSym (liftToSym2 f toSym) v - {-# INLINE liftToSym #-} - -instance - (ToSym1 m1 m2, ToSym a b, ToSym s1 s2) => - ToSym (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym1 m1 m2, ToSym s1 s2) => - ToSym1 (WriterStrict.WriterT s1 m1) (WriterStrict.WriterT s2 m2) - where - liftToSym f (WriterStrict.WriterT v) = - WriterStrict.WriterT $ liftToSym (liftToSym2 f toSym) v - {-# INLINE liftToSym #-} - --- StateT -instance - (ToSym1 m1 m2, ToSym a1 a2, Mergeable s) => - ToSym (StateLazy.StateT s m1 a1) (StateLazy.StateT s m2 a2) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym1 m1 m2, Mergeable s) => - ToSym1 (StateLazy.StateT s m1) (StateLazy.StateT s m2) - where - liftToSym f (StateLazy.StateT f1) = - StateLazy.StateT $ \s -> liftToSym (liftToSym2 f id) $ f1 s - {-# INLINE liftToSym #-} - -instance - (ToSym1 m1 m2, ToSym a1 a2, Mergeable s) => - ToSym (StateStrict.StateT s m1 a1) (StateStrict.StateT s m2 a2) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym1 m1 m2, Mergeable s) => - ToSym1 (StateStrict.StateT s m1) (StateStrict.StateT s m2) - where - liftToSym f (StateStrict.StateT f1) = - StateStrict.StateT $ \s -> liftToSym (liftToSym2 f id) $ f1 s - {-# INLINE liftToSym #-} - --- ReaderT -instance - (ToSym s2 s1, ToSym1 m1 m2, ToSym a1 a2) => - ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) - where - toSym = toSym1 - {-# INLINE toSym #-} - -instance - (ToSym s2 s1, ToSym1 m1 m2, Mergeable1 m2) => - ToSym1 (ReaderT s1 m1) (ReaderT s2 m2) - where - liftToSym :: - forall a b. - (ToSym s2 s1, ToSym1 m1 m2, Mergeable1 m2, Mergeable b) => - (a -> b) -> - ReaderT s1 m1 a -> - ReaderT s2 m2 b - liftToSym f (ReaderT f1) = - resolveMergeable1 @m2 @b $ - ReaderT $ - liftToSym (liftToSym f) f1 - {-# INLINE liftToSym #-} - --- IdentityT -instance (ToSym1 m m1, ToSym a b) => ToSym (IdentityT m a) (IdentityT m1 b) where - toSym = toSym1 - {-# INLINE toSym #-} - -instance (ToSym1 m m1) => ToSym1 (IdentityT m) (IdentityT m1) where - liftToSym f (IdentityT v) = IdentityT $ liftToSym f v - {-# INLINE liftToSym #-} - --- Identity -instance {-# INCOHERENT #-} (ToSym a b) => ToSym (Identity a) (Identity b) where - toSym = toSym1 - {-# INLINE toSym #-} - -instance {-# INCOHERENT #-} (ToSym a b) => ToSym a (Identity b) where - toSym = Identity . toSym - {-# INLINE toSym #-} - -instance {-# INCOHERENT #-} (ToSym a b) => ToSym (Identity a) b where - toSym = toSym . runIdentity - {-# INLINE toSym #-} - -instance ToSym1 Identity Identity where - liftToSym f (Identity v) = Identity $ f v - {-# INLINE liftToSym #-} - --- Function -instance (ToSym b d, ToSym c a) => ToSym (a -> b) (c -> d) where - toSym = toSym1 - {-# INLINE toSym #-} - -instance (ToSym c a) => ToSym1 ((->) a) ((->) c) where - liftToSym l f = l . f . toSym - {-# INLINE liftToSym #-} - --- Product -deriving via - (Default (Product l r a)) - instance - (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) => - ToSym (Product l0 r0 a0) (Product l r a) - -deriving via - (Default1 (Product l r)) - instance - (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Product l0 r0) (Product l r) - --- Sum -deriving via - (Default (Sum l r a)) - instance - (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) => - ToSym (Sum l0 r0 a0) (Sum l r a) - -deriving via - (Default1 (Sum l r)) - instance - (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Sum l0 r0) (Sum l r) - --- Compose -deriving via - (Default (Compose f g a)) - instance - (ToSym (f0 (g0 a0)) (f (g a))) => ToSym (Compose f0 g0 a0) (Compose f g a) - -instance - (ToSym1 f0 f, ToSym1 g0 g) => - ToSym1 (Compose f0 g0) (Compose f g) - where - liftToSym :: - forall a b. - (ToSym1 f0 f, ToSym1 g0 g, Mergeable b) => - (a -> b) -> - Compose f0 g0 a -> - Compose f g b - liftToSym f (Compose v) = - resolveMergeable1 @g @b $ Compose $ liftToSym (liftToSym f) v - {-# INLINE liftToSym #-} - --- Const -deriving via - (Default (Const a b)) - instance - (ToSym a0 a) => ToSym (Const a0 b0) (Const a b) - -deriving via - (Default1 (Const a)) - instance - (ToSym a0 a) => ToSym1 (Const a0) (Const a) - --- Alt -deriving via - (Default (Alt f a)) - instance - (ToSym (f0 a0) (f a)) => ToSym (Alt f0 a0) (Alt f a) - -deriving via - (Default1 (Alt f)) - instance - (ToSym1 f0 f) => ToSym1 (Alt f0) (Alt f) - --- Ap -deriving via - (Default (Ap f a)) - instance - (ToSym (f0 a0) (f a)) => ToSym (Ap f0 a0) (Ap f a) - -deriving via - (Default1 (Ap f)) - instance - (ToSym1 f0 f) => ToSym1 (Ap f0) (Ap f) - --- Generic -deriving via (Default (U1 p)) instance ToSym (U1 p0) (U1 p) - -deriving via (Default (V1 p)) instance ToSym (V1 p0) (V1 p) - -deriving via - (Default (K1 i c p)) - instance - (ToSym c0 c) => ToSym (K1 i0 c0 p0) (K1 i c p) - -deriving via - (Default (M1 i c f p)) - instance - (ToSym (f0 p0) (f p)) => ToSym (M1 i0 c0 f0 p0) (M1 i c f p) - -deriving via - (Default ((f :+: g) p)) - instance - (ToSym (f0 p0) (f p), ToSym (g0 p0) (g p)) => - ToSym ((f0 :+: g0) p0) ((f :+: g) p) - -deriving via - (Default ((f :*: g) p)) - instance - (ToSym (f0 p0) (f p), ToSym (g0 p0) (g p)) => - ToSym ((f0 :*: g0) p0) ((f :*: g) p) - -deriving via - (Default (Par1 p)) - instance - (ToSym p0 p) => ToSym (Par1 p0) (Par1 p) - -deriving via - (Default (Rec1 f p)) - instance - (ToSym (f0 p0) (f p)) => ToSym (Rec1 f0 p0) (Rec1 f p) - -deriving via - (Default ((f :.: g) p)) - instance - (ToSym (f0 (g0 p0)) (f (g p))) => ToSym ((f0 :.: g0) p0) ((f :.: g) p) - --- ToSym2 -instance ToSym2 Either Either where - liftToSym2 f _ (Left a) = Left $ f a - liftToSym2 _ g (Right b) = Right $ g b - {-# INLINE liftToSym2 #-} - -instance ToSym2 (,) (,) where - liftToSym2 f g (a, b) = (f a, g b) - {-# INLINE liftToSym2 #-} - -instance (ToSym a b) => ToSym2 ((,,) a) ((,,) b) where - liftToSym2 f g (a, b, c) = (toSym a, f b, g c) - {-# INLINE liftToSym2 #-} - -instance (ToSym a c, ToSym b d) => ToSym2 ((,,,) a b) ((,,,) c d) where - liftToSym2 f g (a, b, c, d) = (toSym a, toSym b, f c, g d) - {-# INLINE liftToSym2 #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym +import Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym () diff --git a/src/Grisette/Internal/Core/Data/Class/TryMerge.hs b/src/Grisette/Internal/Core/Data/Class/TryMerge.hs --- a/src/Grisette/Internal/Core/Data/Class/TryMerge.hs +++ b/src/Grisette/Internal/Core/Data/Class/TryMerge.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.Core.Data.Class.TryMerge @@ -15,197 +14,10 @@ MonadTryMerge, mrgSingle, mrgSingleWithStrategy, + mrgToSym, + toUnionSym, ) 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" :: Union SymInteger --- {a} --- --- __Note:__ Be careful to call this directly from your code. --- The supplied merge strategy should be consistent with the type's root merge --- strategy, or some internal invariants would be broken and the program can --- crash. --- --- This function is to be called when the 'Mergeable' constraint can not be --- resolved, e.g., the merge strategy for the contained type is given with --- 'Mergeable1'. In other cases, 'Grisette.Lib.Control.Applicative.mrgPure' --- is usually a better alternative. -mrgSingleWithStrategy :: - (TryMerge m, Applicative m) => - MergingStrategy a -> - a -> - m a -mrgSingleWithStrategy strategy = tryMergeWithStrategy strategy . pure -{-# INLINE mrgSingleWithStrategy #-} - --- | Wrap a value in the applicative functor and propagate the type's root merge --- strategy. --- --- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@. --- --- >>> mrgSingle "a" :: Union SymInteger --- {a} -mrgSingle :: (TryMerge m, Applicative m, Mergeable a) => a -> m a -mrgSingle = mrgSingleWithStrategy rootStrategy -{-# INLINE mrgSingle #-} - -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 #-} +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge +import Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge () diff --git a/src/Grisette/Internal/Core/Data/UnionBase.hs b/src/Grisette/Internal/Core/Data/UnionBase.hs --- a/src/Grisette/Internal/Core/Data/UnionBase.hs +++ b/src/Grisette/Internal/Core/Data/UnionBase.hs @@ -1,17 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - -- | -- Module : Grisette.Internal.Core.Data.UnionBase -- Copyright : (c) Sirui Lu 2021-2024 @@ -31,367 +17,10 @@ ) where -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter (align, group, nest, vsep) -#else -import Data.Text.Prettyprint.Doc (align, group, nest, vsep) -#endif - -import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) -import Control.Monad (ap) -import qualified Data.Binary as Binary -import Data.Bytes.Get (MonadGet (getWord8)) -import Data.Bytes.Put (MonadPut (putWord8)) -import Data.Bytes.Serial (Serial (deserialize, serialize)) -import Data.Functor.Classes - ( Eq1 (liftEq), - Show1 (liftShowsPrec), - showsPrec1, - showsUnaryWith, - ) -import Data.Hashable (Hashable (hashWithSalt)) -import qualified Data.Serialize as Cereal -import GHC.Generics (Generic, Generic1) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.Core.Data.Class.LogicalOp - ( LogicalOp (symNot, (.&&), (.||)), - ) -import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), - ) -import Grisette.Internal.Core.Data.Class.PPrint - ( PPrint (pformatPrec), - PPrint1 (liftPFormatPrec), - condEnclose, - pformatPrec1, - ) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( PlainUnion (ifView, singleView), - ) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), - mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable (pattern Con) -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge (tryMergeWithStrategy), - ) -import Grisette.Internal.SymPrim.AllSyms - ( AllSyms (allSymsS), - AllSyms1 (liftAllSymsS), - SomeSym (SomeSym), +import Grisette.Internal.Internal.Decl.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + fullReconstruct, + ifWithLeftMost, + ifWithStrategy, ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Language.Haskell.TH.Syntax (Lift) - --- | The base union implementation, which is an if-then-else tree structure. -data UnionBase a where - -- | A single value - UnionSingle :: a -> UnionBase a - -- | A if value - UnionIf :: - -- | Cached leftmost value - a -> - -- | Is merged invariant already maintained? - !Bool -> - -- | If condition - !SymBool -> - -- | True branch - UnionBase a -> - -- | False branch - UnionBase a -> - UnionBase a - deriving (Generic, Eq, Lift, Generic1) - deriving (Functor) - -instance Applicative UnionBase where - pure = UnionSingle - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} - -instance Monad UnionBase where - return = pure - {-# INLINE return #-} - UnionSingle a >>= f = f a - UnionIf _ _ c t f >>= f' = ifWithLeftMost False c (t >>= f') (f >>= f') - {-# INLINE (>>=) #-} - -instance Eq1 UnionBase where - liftEq e (UnionSingle a) (UnionSingle b) = e a b - liftEq e (UnionIf l1 i1 c1 t1 f1) (UnionIf l2 i2 c2 t2 f2) = - e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 - liftEq _ _ _ = False - -instance (NFData a) => NFData (UnionBase a) where - rnf = rnf1 - -instance NFData1 UnionBase where - liftRnf _a (UnionSingle a) = _a a - liftRnf _a (UnionIf a bo b l r) = - _a a `seq` - rnf bo `seq` - rnf b `seq` - liftRnf _a l `seq` - liftRnf _a r - --- | Build 'UnionIf' with leftmost cache correctly maintained. --- --- Usually you should never directly try to build a 'UnionIf' with its --- constructor. -ifWithLeftMost :: Bool -> SymBool -> UnionBase a -> UnionBase a -> UnionBase a -ifWithLeftMost _ (Con c) t f - | c = t - | otherwise = f -ifWithLeftMost inv cond t f = UnionIf (leftMost t) inv cond t f -{-# INLINE ifWithLeftMost #-} - -instance PlainUnion UnionBase where - singleView (UnionSingle a) = Just a - singleView _ = Nothing - {-# INLINE singleView #-} - ifView (UnionIf _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) - ifView _ = Nothing - {-# INLINE ifView #-} - -leftMost :: UnionBase a -> a -leftMost (UnionSingle a) = a -leftMost (UnionIf a _ _ _ _) = a -{-# INLINE leftMost #-} - -instance (Mergeable a) => Mergeable (UnionBase a) where - rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy - {-# INLINE rootStrategy #-} - -instance (Mergeable a, Serial a) => Serial (UnionBase a) where - serialize (UnionSingle a) = putWord8 0 >> serialize a - serialize (UnionIf _ _ c a b) = - putWord8 1 >> serialize c >> serialize a >> serialize b - deserialize = do - tag <- getWord8 - case tag of - 0 -> UnionSingle <$> deserialize - 1 -> - ifWithStrategy rootStrategy - <$> deserialize - <*> deserialize - <*> deserialize - _ -> fail "Invalid tag" - -instance (Mergeable a, Serial a) => Cereal.Serialize (UnionBase a) where - put = serialize - get = deserialize - -instance (Mergeable a, Serial a) => Binary.Binary (UnionBase a) where - put = serialize - get = deserialize - -instance Mergeable1 UnionBase where - liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms - {-# INLINE liftRootStrategy #-} - -instance (Mergeable a) => SimpleMergeable (UnionBase a) where - mrgIte = mrgIf - -instance SimpleMergeable1 UnionBase where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - -instance TryMerge UnionBase where - tryMergeWithStrategy = fullReconstruct - {-# INLINE tryMergeWithStrategy #-} - -instance SymBranching UnionBase where - mrgIfWithStrategy = ifWithStrategy - {-# INLINE mrgIfWithStrategy #-} - - mrgIfPropagatedStrategy = ifWithLeftMost False - {-# INLINE mrgIfPropagatedStrategy #-} - -instance Show1 UnionBase where - liftShowsPrec sp _ i (UnionSingle a) = showsUnaryWith sp "Single" i a - liftShowsPrec sp sl i (UnionIf _ _ cond t f) = - showParen (i > 10) $ - showString "If" - . showChar ' ' - . showsPrec 11 cond - . showChar ' ' - . sp1 11 t - . showChar ' ' - . sp1 11 f - where - sp1 = liftShowsPrec sp sl - -instance (Show a) => Show (UnionBase a) where - showsPrec = showsPrec1 - -instance (PPrint a) => PPrint (UnionBase a) where - pformatPrec = pformatPrec1 - -instance PPrint1 UnionBase where - liftPFormatPrec fa _ n (UnionSingle a) = fa n a - liftPFormatPrec fa fl n (UnionIf _ _ cond t f) = - group $ - condEnclose (n > 10) "(" ")" $ - align $ - nest 2 $ - vsep - [ "If", - pformatPrec 11 cond, - liftPFormatPrec fa fl 11 t, - liftPFormatPrec fa fl 11 f - ] - -instance (Hashable a) => Hashable (UnionBase a) where - s `hashWithSalt` (UnionSingle a) = - s `hashWithSalt` (0 :: Int) `hashWithSalt` a - s `hashWithSalt` (UnionIf _ _ c l r) = - s - `hashWithSalt` (1 :: Int) - `hashWithSalt` c - `hashWithSalt` l - `hashWithSalt` r - -instance (AllSyms a) => AllSyms (UnionBase a) where - allSymsS (UnionSingle v) = allSymsS v - allSymsS (UnionIf _ _ c t f) = \l -> SomeSym c : (allSymsS t . allSymsS f $ l) - -instance AllSyms1 UnionBase where - liftAllSymsS fa (UnionSingle v) = fa v - liftAllSymsS fa (UnionIf _ _ c t f) = - \l -> SomeSym c : (liftAllSymsS fa t . liftAllSymsS fa f $ l) - --- | Fully reconstruct a 'Grisette.Core.Union' to maintain the merged invariant. -fullReconstruct :: MergingStrategy a -> UnionBase a -> UnionBase a -fullReconstruct strategy (UnionIf _ False cond t f) = - ifWithStrategyInv - strategy - cond - (fullReconstruct strategy t) - (fullReconstruct strategy f) -fullReconstruct _ u = u -{-# INLINE fullReconstruct #-} - --- | Use a specific strategy to build a 'UnionIf' value. --- --- The merged invariant will be maintained in the result. -ifWithStrategy :: - MergingStrategy a -> - SymBool -> - UnionBase a -> - UnionBase a -> - UnionBase a -ifWithStrategy strategy cond t@(UnionIf _ False _ _ _) f = - ifWithStrategy strategy cond (fullReconstruct strategy t) f -ifWithStrategy strategy cond t f@(UnionIf _ False _ _ _) = - ifWithStrategy strategy cond t (fullReconstruct strategy f) -ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f -{-# INLINE ifWithStrategy #-} - -ifWithStrategyInv :: - MergingStrategy a -> - SymBool -> - UnionBase a -> - UnionBase a -> - UnionBase a -ifWithStrategyInv _ (Con v) t f - | v = t - | otherwise = f -ifWithStrategyInv strategy cond (UnionIf _ True condTrue tt _) f - | cond == condTrue = ifWithStrategyInv strategy cond tt f --- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond ft f -ifWithStrategyInv strategy cond t (UnionIf _ True condFalse _ ff) - | cond == condFalse = ifWithStrategyInv strategy cond t ff --- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond t tf -- buggy here condTrue -ifWithStrategyInv (SimpleStrategy m) cond (UnionSingle l) (UnionSingle r) = - UnionSingle $ m cond l r -ifWithStrategyInv - strategy@(SortedStrategy idxFun substrategy) - cond - ifTrue - ifFalse = case (ifTrue, ifFalse) of - (UnionSingle _, UnionSingle _) -> ssUnionIf cond ifTrue ifFalse - (UnionSingle _, UnionIf {}) -> sgUnionIf cond ifTrue ifFalse - (UnionIf {}, UnionSingle _) -> gsUnionIf cond ifTrue ifFalse - _ -> ggUnionIf cond ifTrue ifFalse - where - ssUnionIf cond' ifTrue' ifFalse' - | idxt < idxf = ifWithLeftMost True cond' ifTrue' ifFalse' - | idxt == idxf = - ifWithStrategyInv (substrategy idxt) cond' ifTrue' ifFalse' - | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' - where - idxt = idxFun $ leftMost ifTrue' - idxf = idxFun $ leftMost ifFalse' - {-# INLINE ssUnionIf #-} - sgUnionIf cond' ifTrue' ifFalse'@(UnionIf _ True condf ft ff) - | idxft == idxff = ssUnionIf cond' ifTrue' ifFalse' - | idxt < idxft = ifWithLeftMost True cond' ifTrue' ifFalse' - | idxt == idxft = - ifWithLeftMost - True - (cond' .|| condf) - (ifWithStrategyInv (substrategy idxt) cond' ifTrue' ft) - ff - | otherwise = - ifWithLeftMost - True - (symNot cond' .&& condf) - ft - (ifWithStrategyInv strategy cond' ifTrue' ff) - where - idxft = idxFun $ leftMost ft - idxff = idxFun $ leftMost ff - idxt = idxFun $ leftMost ifTrue' - sgUnionIf _ _ _ = undefined - {-# INLINE sgUnionIf #-} - gsUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse' - | idxtt == idxtf = ssUnionIf cond' ifTrue' ifFalse' - | idxtt < idxf = - ifWithLeftMost True (cond' .&& condt) tt $ - ifWithStrategyInv strategy cond' tf ifFalse' - | idxtt == idxf = - ifWithLeftMost - True - (symNot cond' .|| condt) - (ifWithStrategyInv (substrategy idxf) cond' tt ifFalse') - tf - | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' - where - idxtt = idxFun $ leftMost tt - idxtf = idxFun $ leftMost tf - idxf = idxFun $ leftMost ifFalse' - gsUnionIf _ _ _ = undefined - {-# INLINE gsUnionIf #-} - ggUnionIf - cond' - ifTrue'@(UnionIf _ True condt tt tf) - ifFalse'@(UnionIf _ True condf ft ff) - | idxtt == idxtf = sgUnionIf cond' ifTrue' ifFalse' - | idxft == idxff = gsUnionIf cond' ifTrue' ifFalse' - | idxtt < idxft = - ifWithLeftMost True (cond' .&& condt) tt $ - ifWithStrategyInv strategy cond' tf ifFalse' - | idxtt == idxft = - let newCond = symIte cond' condt condf - newUnionIfTrue = - ifWithStrategyInv (substrategy idxtt) cond' tt ft - newUnionIfFalse = ifWithStrategyInv strategy cond' tf ff - in ifWithLeftMost True newCond newUnionIfTrue newUnionIfFalse - | otherwise = - ifWithLeftMost True (symNot cond' .&& condf) ft $ - ifWithStrategyInv strategy cond' ifTrue' ff - where - idxtt = idxFun $ leftMost tt - idxtf = idxFun $ leftMost tf - idxft = idxFun $ leftMost ft - idxff = idxFun $ leftMost ff - ggUnionIf _ _ _ = undefined - {-# INLINE ggUnionIf #-} -ifWithStrategyInv NoStrategy cond ifTrue ifFalse = - ifWithLeftMost True cond ifTrue ifFalse -ifWithStrategyInv _ _ _ _ = error "Invariant violated" -{-# INLINE ifWithStrategyInv #-} +import Grisette.Internal.Internal.Impl.Core.Data.UnionBase () diff --git a/src/Grisette/Internal/Internal/Decl/Core/Control/Monad/Union.hs b/src/Grisette/Internal/Internal/Decl/Core/Control/Monad/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Control/Monad/Union.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use <&>" #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Control.Monad.Union +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Control.Monad.Union + ( -- * Union and helpers + Union (..), + unionBase, + ) +where + +import Data.String (IsString (fromString)) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (ifView, singleView), + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, sym), + pattern Con, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (SimpleStrategy), + rootStrategy1, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Internal.Decl.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + ifWithLeftMost, + ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | 'Union' is the 'UnionBase' container (hidden) enhanced with +-- 'MergingStrategy' +-- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). +-- +-- The 'UnionBase' models the underlying semantics evaluation semantics for +-- unsolvable types with the nested if-then-else tree semantics, and can be +-- viewed as the following structure: +-- +-- > data UnionBase a +-- > = UnionSingle a +-- > | UnionIf bool (Union a) (Union a) +-- +-- The 'UnionSingle' constructor is for a single value with the path condition +-- @true@, and the 'UnionIf' constructor is the if operator in an if-then-else +-- tree. +-- For clarity, when printing a 'Union' value, we will omit the 'UnionSingle' +-- constructor. The following two representations has the same semantics. +-- +-- > If c1 (If c11 v11 (If c12 v12 v13)) +-- > (If c2 v2 +-- > v3) +-- +-- \[ +-- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. +-- \] +-- +-- To reduce the size of the if-then-else tree to reduce the number of paths to +-- execute, Grisette would merge the branches in a 'UnionBase' container and +-- maintain a representation invariant for them. To perform this merging +-- procedure, Grisette relies on a type class called 'Mergeable' and the +-- merging strategy defined by it. +-- +-- 'UnionBase' is a monad, so we can easily write code with the do-notation and +-- monadic combinators. However, the standard monadic operators cannot +-- resolve any extra constraints, including the 'Mergeable' constraint (see +-- [The constrained-monad +-- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) +-- by Sculthorpe et al.). +-- This prevents the standard do-notations to merge the results automatically, +-- and would result in bad performance or very verbose code. +-- +-- To reduce this boilerplate, Grisette provide another monad, 'Union' that +-- would try to cache the merging strategy. +-- The 'Union' has two data constructors (hidden intentionally), 'UAny' and +-- 'UMrg'. The 'UAny' data constructor (printed as @<@@...@@>@) wraps an +-- arbitrary (probably unmerged) 'UnionBase'. It is constructed when no +-- 'Mergeable' knowledge is available (for example, when constructed with +-- Haskell\'s 'return'). The 'UMrg' data constructor (printed as @{...}@) wraps +-- a merged 'UnionBase' along with the 'Mergeable' constraint. This constraint +-- can be propagated to the contexts without 'Mergeable' knowledge, and helps +-- the system to merge the resulting 'UnionBase'. +-- +-- __/Examples:/__ +-- +-- 'return' cannot resolve the 'Mergeable' constraint. +-- +-- >>> return 1 :: Union Integer +-- <1> +-- +-- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. +-- +-- >>> import Grisette.Lib.Base +-- >>> mrgReturn 1 :: Union Integer +-- {1} +-- +-- 'mrgIfPropagatedStrategy' does not try to 'Mergeable' constraint. +-- +-- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (return 1) (return 2)) :: Union Integer +-- +-- +-- But 'mrgIfPropagatedStrategy' is able to merge the result if some of the +-- branches are merged and have a cached merging strategy: +-- +-- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (mrgReturn 1) (return 2)) :: Union Integer +-- {If (|| a b) 1 2} +-- +-- The '>>=' operator uses 'mrgIfPropagatedStrategy' internally. When the final +-- statement in a do-block merges the values, the system can then merge the +-- final result. +-- +-- >>> :{ +-- do +-- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) +-- mrgSingle $ x + 1 :: Union Integer +-- :} +-- {If (|| a b) 2 3} +-- +-- Calling a function that merges a result at the last line of a do-notation +-- will also merge the whole block. If you stick to these @mrg*@ combinators and +-- all the functions will merge the results, the whole program can be +-- symbolically evaluated efficiently. +-- +-- >>> f x y = mrgIf "c" x y :: Union Integer +-- >>> :{ +-- do +-- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) +-- f x (x + 1) +-- :} +-- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} +-- +-- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ +-- variants of other combinators. You should stick to these combinators to +-- ensure efficient merging by Grisette. +data Union a where + -- | 'Union' with no 'Mergeable' knowledge. + UAny :: + -- | Original 'UnionBase'. + UnionBase a -> + Union a + -- | 'Union' with 'Mergeable' knowledge. + UMrg :: + -- | Cached merging strategy. + MergingStrategy a -> + -- | Merged 'UnionBase' + UnionBase a -> + Union a + +-- | Extract the underlying Union. May be unmerged. +unionBase :: Union a -> UnionBase a +unionBase (UAny a) = a +unionBase (UMrg _ a) = a +{-# INLINE unionBase #-} + +instance Functor Union where + fmap f fa = fa >>= return . f + {-# INLINE fmap #-} + +instance Applicative Union where + pure = UAny . pure + {-# INLINE pure #-} + f <*> a = f >>= (\xf -> a >>= (return . xf)) + {-# INLINE (<*>) #-} + +bindUnionBase :: UnionBase a -> (a -> Union b) -> Union b +bindUnionBase (UnionSingle a') f' = f' a' +bindUnionBase (UnionIf _ _ cond ifTrue ifFalse) f' = + mrgIfPropagatedStrategy + cond + (bindUnionBase ifTrue f') + (bindUnionBase ifFalse f') +{-# INLINE bindUnionBase #-} + +instance Monad Union where + a >>= f = bindUnionBase (unionBase a) f + {-# INLINE (>>=) #-} + +instance TryMerge Union where + tryMergeWithStrategy _ m@(UMrg _ _) = m + tryMergeWithStrategy s (UAny u) = UMrg s $ tryMergeWithStrategy s u + {-# INLINE tryMergeWithStrategy #-} + +instance (IsString a, Mergeable a) => IsString (Union a) where + fromString = mrgSingle . fromString + +instance (Solvable c t, Mergeable t) => Solvable c (Union t) where + con = mrgSingle . con + {-# INLINE con #-} + sym = mrgSingle . sym + {-# INLINE sym #-} + conView v = do + c <- singleView $ tryMerge v + conView c + {-# INLINE conView #-} + +instance (Mergeable a) => Mergeable (Union a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (Union a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance Mergeable1 Union where + liftRootStrategy m = SimpleStrategy $ mrgIfWithStrategy m + {-# INLINE liftRootStrategy #-} + +instance SimpleMergeable1 Union where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance SymBranching Union where + mrgIfWithStrategy s (Con c) l r = + if c then tryMergeWithStrategy s l else tryMergeWithStrategy s r + mrgIfWithStrategy s cond l r = + UMrg s $ + mrgIfWithStrategy + s + cond + (unionBase l) + (unionBase r) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (UAny t) (UAny f) = + UAny $ ifWithLeftMost False cond t f + mrgIfPropagatedStrategy cond t@(UMrg m _) f = mrgIfWithStrategy m cond t f + mrgIfPropagatedStrategy cond t f@(UMrg m _) = mrgIfWithStrategy m cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance PlainUnion Union where + singleView = singleView . unionBase + {-# INLINE singleView #-} + ifView (UAny u) = case ifView u of + Just (c, t, f) -> Just (c, UAny t, UAny f) + Nothing -> Nothing + ifView (UMrg m u) = case ifView u of + Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) + Nothing -> Nothing + {-# INLINE ifView #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/EvalSym.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/EvalSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/EvalSym.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym + ( -- * Evaluating symbolic values with model + EvalSym (..), + evalSymToCon, + EvalSym1 (..), + evalSym1, + evalSymToCon1, + EvalSym2 (..), + evalSym2, + evalSymToCon2, + + -- * Generic 'EvalSym' + EvalSymArgs (..), + GEvalSym (..), + genericEvalSym, + genericLiftEvalSym, + ) +where + +import Data.Kind (Type) +import Data.Maybe (fromJust) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving.Instances () +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon + ( ToCon (toCon), + ToCon1, + ToCon2, + toCon1, + toCon2, + ) +import Grisette.Internal.SymPrim.Prim.Model (Model) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Data.Proxy + +-- | Evaluating symbolic values with some model. This would substitute the +-- symbols (symbolic constants) with the values in the model. +-- +-- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model +-- >>> evalSym False model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,b] +-- +-- If we set the first argument true, the missing symbols will be filled in +-- with some default values: +-- +-- >>> evalSym True model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,0] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving EvalSym via (Default X) +class EvalSym a where + -- | Evaluate a symbolic value with some model, possibly fill in values for + -- the missing symbols. + evalSym :: Bool -> Model -> a -> a + +-- | Evaluate a symbolic value with some model, fill in values for the missing +-- symbols, and convert the result to a concrete value. +-- +-- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model +-- >>> evalSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] +-- [1,0] +evalSymToCon :: (ToCon a b, EvalSym a) => Model -> a -> b +evalSymToCon model a = fromJust $ toCon $ evalSym True model a + +-- | Lifting of 'EvalSym' to unary type constructors. +class (forall a. (EvalSym a) => EvalSym (f a)) => EvalSym1 f where + -- | Lift the 'evalSym' function to unary type constructors. + liftEvalSym :: (Bool -> Model -> a -> a) -> (Bool -> Model -> f a -> f a) + +-- | Lifting the standard 'evalSym' to unary type constructors. +evalSym1 :: (EvalSym1 f, EvalSym a) => Bool -> Model -> f a -> f a +evalSym1 = liftEvalSym evalSym +{-# INLINE evalSym1 #-} + +-- | Evaluate and convert to concrete values with lifted standard 'evalSym' for +-- unary type constructors. See 'evalSymToCon'. +evalSymToCon1 :: + (EvalSym1 f, EvalSym a, ToCon1 f g, ToCon a b) => + Model -> + f a -> + g b +evalSymToCon1 model a = fromJust $ toCon1 $ evalSym1 True model a +{-# INLINE evalSymToCon1 #-} + +-- | Lifting of 'EvalSym1' to binary type constructors. +class (forall a. (EvalSym a) => EvalSym1 (f a)) => EvalSym2 f where + -- | Lift the 'evalSym' function to binary type constructors. + liftEvalSym2 :: + (Bool -> Model -> a -> a) -> + (Bool -> Model -> b -> b) -> + (Bool -> Model -> f a b -> f a b) + +-- | Lifting the standard 'evalSym' to binary type constructors. +evalSym2 :: + (EvalSym2 f, EvalSym a, EvalSym b) => + Bool -> + Model -> + f a b -> + f a b +evalSym2 = liftEvalSym2 evalSym evalSym +{-# INLINE evalSym2 #-} + +-- | Evaluate and convert to concrete values with lifted standard 'evalSym' for +-- binary type constructors. See 'evalSymToCon'. +evalSymToCon2 :: + ( EvalSym2 f, + EvalSym a, + EvalSym c, + ToCon2 f g, + ToCon a b, + ToCon c d + ) => + Model -> + f a c -> + g b d +evalSymToCon2 model a = fromJust $ toCon2 $ evalSym2 True model a +{-# INLINE evalSymToCon2 #-} + +-- Derivations + +-- | The arguments to the generic 'evalSym' function. +data family EvalSymArgs arity a :: Type + +data instance EvalSymArgs Arity0 _ = EvalSymArgs0 + +newtype instance EvalSymArgs Arity1 a + = EvalSymArgs1 (Bool -> Model -> a -> a) + +-- | The class of types that can be generically evaluated. +class GEvalSym arity f where + gevalSym :: EvalSymArgs arity a -> Bool -> Model -> f a -> f a + +instance GEvalSym arity V1 where + gevalSym _ _ _ = id + {-# INLINE gevalSym #-} + +instance GEvalSym arity U1 where + gevalSym _ _ _ = id + {-# INLINE gevalSym #-} + +instance + (GEvalSym arity a, GEvalSym arity b) => + GEvalSym arity (a :*: b) + where + gevalSym args fillDefault model (a :*: b) = + gevalSym args fillDefault model a + :*: gevalSym args fillDefault model b + {-# INLINE gevalSym #-} + +instance + (GEvalSym arity a, GEvalSym arity b) => + GEvalSym arity (a :+: b) + where + gevalSym args fillDefault model (L1 l) = + L1 $ gevalSym args fillDefault model l + gevalSym args fillDefault model (R1 r) = + R1 $ gevalSym args fillDefault model r + {-# INLINE gevalSym #-} + +instance (GEvalSym arity a) => GEvalSym arity (M1 i c a) where + gevalSym args fillDefault model (M1 x) = + M1 $ gevalSym args fillDefault model x + {-# INLINE gevalSym #-} + +instance (EvalSym a) => GEvalSym arity (K1 i a) where + gevalSym _ fillDefault model (K1 x) = K1 $ evalSym fillDefault model x + {-# INLINE gevalSym #-} + +instance GEvalSym Arity1 Par1 where + gevalSym (EvalSymArgs1 f) fillDefault model (Par1 x) = + Par1 $ f fillDefault model x + {-# INLINE gevalSym #-} + +instance (EvalSym1 a) => GEvalSym Arity1 (Rec1 a) where + gevalSym (EvalSymArgs1 f) fillDefault model (Rec1 x) = + Rec1 $ liftEvalSym f fillDefault model x + {-# INLINE gevalSym #-} + +instance + (EvalSym1 f, GEvalSym Arity1 g) => + GEvalSym Arity1 (f :.: g) + where + gevalSym targs fillDefault model (Comp1 x) = + Comp1 $ liftEvalSym (gevalSym targs) fillDefault model x + {-# INLINE gevalSym #-} + +-- | Generic 'evalSym' function. +genericEvalSym :: + (Generic a, GEvalSym Arity0 (Rep a)) => Bool -> Model -> a -> a +genericEvalSym fillDefault model = + to . gevalSym EvalSymArgs0 fillDefault model . from +{-# INLINE genericEvalSym #-} + +-- | Generic 'liftEvalSym' function. +genericLiftEvalSym :: + (Generic1 f, GEvalSym Arity1 (Rep1 f)) => + (Bool -> Model -> a -> a) -> + Bool -> + Model -> + f a -> + f a +genericLiftEvalSym f fillDefault model = + to1 . gevalSym (EvalSymArgs1 f) fillDefault model . from1 +{-# INLINE genericLiftEvalSym #-} + +instance + (Generic a, GEvalSym Arity0 (Rep a)) => + EvalSym (Default a) + where + evalSym fillDefault model = + Default . genericEvalSym fillDefault model . unDefault + {-# INLINE evalSym #-} + +instance + (Generic1 f, GEvalSym Arity1 (Rep1 f), EvalSym a) => + EvalSym (Default1 f a) + where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance + (Generic1 f, GEvalSym Arity1 (Rep1 f)) => + EvalSym1 (Default1 f) + where + liftEvalSym f fillDefault model = + Default1 . genericLiftEvalSym f fillDefault model . unDefault1 + {-# INLINE liftEvalSym #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ExtractSym.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ExtractSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ExtractSym.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym + ( -- * Extracting symbolic constant set from a value + ExtractSym (..), + ExtractSym1 (..), + extractSymMaybe1, + extractSym1, + ExtractSym2 (..), + extractSymMaybe2, + extractSym2, + + -- * Generic 'ExtractSym' + ExtractSymArgs (..), + GExtractSym (..), + genericExtractSymMaybe, + genericLiftExtractSymMaybe, + ) +where + +import Data.Kind (Type) +import Data.Maybe (fromJust) +import Generics.Deriving + ( Default (unDefault), + Default1 (unDefault1), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + type (:.:) (Comp1), + ) +import Grisette.Internal.SymPrim.Prim.Model + ( AnySymbolSet, + SymbolSet, + ) +import Grisette.Internal.SymPrim.Prim.Term (IsSymbolKind, SymbolKind) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Lib.Base +-- >>> import Data.HashSet as HashSet +-- >>> import Data.List (sort) + +-- | Extracts all the symbols (symbolic constants) that are transitively +-- contained in the given value. +-- +-- >>> extractSym ("a" :: SymBool) +-- SymbolSet {a :: Bool} +-- +-- >>> extractSym (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: Union [SymBool]) +-- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving ExtractSym via (Default X) +class ExtractSym a where + extractSym :: a -> AnySymbolSet + extractSym = fromJust . extractSymMaybe + {-# INLINE extractSym #-} + extractSymMaybe :: (IsSymbolKind knd) => a -> Maybe (SymbolSet knd) + +-- | Lifting of 'ExtractSym' to unary type constructors. +class + (forall a. (ExtractSym a) => ExtractSym (f a)) => + ExtractSym1 f + where + -- | Lifts the 'extractSymMaybe' function to unary type constructors. + liftExtractSymMaybe :: + (IsSymbolKind knd) => + (a -> Maybe (SymbolSet knd)) -> + f a -> + Maybe (SymbolSet knd) + +-- | Lift the standard 'extractSym' to unary type constructors. +extractSym1 :: + (ExtractSym1 f, ExtractSym a, IsSymbolKind knd) => + f a -> + SymbolSet knd +extractSym1 = fromJust . liftExtractSymMaybe extractSymMaybe +{-# INLINE extractSym1 #-} + +-- | Lift the standard 'extractSymMaybe' to unary type constructors. +extractSymMaybe1 :: + (ExtractSym1 f, ExtractSym a, IsSymbolKind knd) => + f a -> + Maybe (SymbolSet knd) +extractSymMaybe1 = liftExtractSymMaybe extractSymMaybe +{-# INLINE extractSymMaybe1 #-} + +-- | Lifting of 'ExtractSym' to binary type constructors. +class + (forall a. (ExtractSym a) => ExtractSym1 (f a)) => + ExtractSym2 f + where + -- | Lifts the 'extractSymMaybe' function to binary type constructors. + liftExtractSymMaybe2 :: + (IsSymbolKind knd) => + (a -> Maybe (SymbolSet knd)) -> + (b -> Maybe (SymbolSet knd)) -> + f a b -> + Maybe (SymbolSet knd) + +-- | Lift the standard 'extractSym' to binary type constructors. +extractSym2 :: + (ExtractSym2 f, ExtractSym a, ExtractSym b, IsSymbolKind knd) => + f a b -> + SymbolSet knd +extractSym2 = fromJust . liftExtractSymMaybe2 extractSymMaybe extractSymMaybe + +-- | Lift the standard 'extractSymMaybe' to binary type constructors. +extractSymMaybe2 :: + (ExtractSym2 f, ExtractSym a, ExtractSym b, IsSymbolKind knd) => + f a b -> + Maybe (SymbolSet knd) +extractSymMaybe2 = liftExtractSymMaybe2 extractSymMaybe extractSymMaybe +{-# INLINE extractSymMaybe2 #-} + +-- Derivations + +-- | The arguments to the generic 'extractSym' function. +data family ExtractSymArgs arity (knd :: SymbolKind) a :: Type + +data instance ExtractSymArgs Arity0 _ _ = ExtractSymArgs0 + +newtype instance ExtractSymArgs Arity1 knd a + = ExtractSymArgs1 (a -> Maybe (SymbolSet knd)) + +-- | The class of types that can generically extract the symbols. +class GExtractSym arity f where + gextractSymMaybe :: + (IsSymbolKind knd) => + ExtractSymArgs arity knd a -> + f a -> + Maybe (SymbolSet knd) + +instance GExtractSym arity V1 where + gextractSymMaybe _ _ = Just mempty + {-# INLINE gextractSymMaybe #-} + +instance GExtractSym arity U1 where + gextractSymMaybe _ _ = Just mempty + {-# INLINE gextractSymMaybe #-} + +instance (GExtractSym arity a) => GExtractSym arity (M1 i c a) where + gextractSymMaybe args (M1 x) = gextractSymMaybe args x + {-# INLINE gextractSymMaybe #-} + +instance (ExtractSym a) => GExtractSym arity (K1 i a) where + gextractSymMaybe _ (K1 x) = extractSymMaybe x + {-# INLINE gextractSymMaybe #-} + +instance + (GExtractSym arity a, GExtractSym arity b) => + GExtractSym arity (a :+: b) + where + gextractSymMaybe args (L1 x) = gextractSymMaybe args x + gextractSymMaybe args (R1 x) = gextractSymMaybe args x + {-# INLINE gextractSymMaybe #-} + +instance + (GExtractSym arity a, GExtractSym arity b) => + GExtractSym arity (a :*: b) + where + gextractSymMaybe args (x :*: y) = + gextractSymMaybe args x <> gextractSymMaybe args y + {-# INLINE gextractSymMaybe #-} + +instance GExtractSym Arity1 Par1 where + gextractSymMaybe (ExtractSymArgs1 f) (Par1 x) = f x + {-# INLINE gextractSymMaybe #-} + +instance (ExtractSym1 a) => GExtractSym Arity1 (Rec1 a) where + gextractSymMaybe (ExtractSymArgs1 f) (Rec1 x) = + liftExtractSymMaybe f x + {-# INLINE gextractSymMaybe #-} + +instance + (ExtractSym1 f, GExtractSym Arity1 g) => + GExtractSym Arity1 (f :.: g) + where + gextractSymMaybe targs (Comp1 x) = + liftExtractSymMaybe (gextractSymMaybe targs) x + {-# INLINE gextractSymMaybe #-} + +-- | Generic 'extractSym' function. +genericExtractSymMaybe :: + (Generic a, GExtractSym Arity0 (Rep a), IsSymbolKind knd) => + a -> + Maybe (SymbolSet knd) +genericExtractSymMaybe = gextractSymMaybe ExtractSymArgs0 . from + +-- | Generic 'liftExtractSymMaybe' function. +genericLiftExtractSymMaybe :: + (Generic1 f, GExtractSym Arity1 (Rep1 f), IsSymbolKind knd) => + (a -> Maybe (SymbolSet knd)) -> + f a -> + Maybe (SymbolSet knd) +genericLiftExtractSymMaybe f = + gextractSymMaybe (ExtractSymArgs1 f) . from1 + +instance + (Generic a, GExtractSym Arity0 (Rep a)) => + ExtractSym (Default a) + where + extractSymMaybe = genericExtractSymMaybe . unDefault + {-# INLINE extractSymMaybe #-} + +instance + (Generic1 f, GExtractSym Arity1 (Rep1 f), ExtractSym a) => + ExtractSym (Default1 f a) + where + extractSymMaybe = extractSymMaybe1 + {-# INLINE extractSymMaybe #-} + +instance + (Generic1 f, GExtractSym Arity1 (Rep1 f)) => + ExtractSym1 (Default1 f) + where + liftExtractSymMaybe f = genericLiftExtractSymMaybe f . unDefault1 + {-# INLINE liftExtractSymMaybe #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/Mergeable.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/Mergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/Mergeable.hs @@ -0,0 +1,530 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( -- * Merging strategy + MergingStrategy (..), + + -- * Mergeable + Mergeable (..), + Mergeable1 (..), + rootStrategy1, + Mergeable2 (..), + rootStrategy2, + Mergeable3 (..), + rootStrategy3, + + -- * Generic 'Mergeable' + MergeableArgs (..), + GMergeable (..), + genericRootStrategy, + genericLiftRootStrategy, + + -- * Combinators for manually building merging strategies + wrapStrategy, + product2Strategy, + DynamicSortedIdx (..), + StrategyList (..), + buildStrategyList, + resolveStrategy, + resolveStrategy', + resolveMergeable1, + ) +where + +import Data.Functor.Classes + ( Eq1, + Ord1, + Show1, + compare1, + eq1, + showsPrec1, + ) +import Data.Kind (Type) +import Data.Typeable + ( Typeable, + eqT, + type (:~:) (Refl), + ) +import Generics.Deriving + ( Default, + Default1, + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1, unK1), + M1 (M1, unM1), + Par1 (Par1, unPar1), + Rec1 (Rec1, unRec1), + U1, + V1, + (:.:) (Comp1, unComp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) +import Unsafe.Coerce (unsafeCoerce) + +-- | Merging strategies. +-- +-- __You probably do not need to know the details of this type if you are only__ +-- __going to use algebraic data types. You can get merging strategies for__ +-- __them with type derivation.__ +-- +-- In Grisette, a merged union (if-then-else tree) follows the +-- __/hierarchical sorted representation invariant/__ with regards to some +-- merging strategy. +-- +-- A merging strategy encodes how to merge a __/subset/__ of the values of a +-- given type. We have three types of merging strategies: +-- +-- * Simple strategy +-- * Sorted strategy +-- * No strategy +-- +-- The 'SimpleStrategy' merges values with a simple merge function. +-- For example, +-- +-- * the symbolic boolean values can be directly merged with 'symIte'. +-- +-- * the set @{1}@, which is a subset of the values of the type @Integer@, +-- can be simply merged as the set contains only a single value. +-- +-- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged +-- by merging the wrapped symbolic boolean with 'symIte'. +-- +-- The 'SortedStrategy' merges values by first grouping the values with an +-- indexing function, and the values with the same index will be organized as +-- a sub-tree in the if-then-else structure of +-- 'Grisette.Core.Data.UnionBase.UnionBase'. Each group (sub-tree) will be +-- further merged with a sub-strategy for the index. +-- The index type should be a totally ordered type (with the 'Ord' +-- type class). Grisette will use the indexing function to partition the values +-- into sub-trees, and organize them in a sorted way. The sub-trees will further +-- be merged with the sub-strategies. For example, +-- +-- * all the integers can be merged with 'SortedStrategy' by indexing with +-- the identity function and use the 'SimpleStrategy' shown before as the +-- sub-strategies. +-- +-- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by +-- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can +-- then be merged with different simple strategies as sub-strategies. +-- +-- The 'NoStrategy' does not perform any merging. +-- For example, we cannot merge values with function types that returns concrete +-- lists. +-- +-- For ADTs, we can automatically derive the 'Mergeable' type class, which +-- provides a merging strategy. +-- +-- If the derived version does not work for you, you should determine +-- if your type can be directly merged with a merging function. If so, you can +-- implement the merging strategy as a 'SimpleStrategy'. +-- If the type cannot be directly merged with a merging function, but could be +-- partitioned into subsets of values that can be simply merged with a function, +-- you should implement the merging strategy as a 'SortedStrategy'. +-- For easier building of the merging strategies, check out the combinators +-- like `wrapStrategy`. +-- +-- For more details, please see the documents of the constructors, or refer to +-- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). +data MergingStrategy a where + -- | Simple mergeable strategy. + -- + -- For symbolic booleans, we can implement its merge strategy as follows: + -- + -- > SimpleStrategy symIte :: MergingStrategy SymBool + SimpleStrategy :: + -- | Merge function. + (SymBool -> a -> a -> a) -> + MergingStrategy a + -- | Sorted mergeable strategy. + -- + -- For Integers, we can implement its merge strategy as follows: + -- + -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) + -- + -- For @Maybe SymBool@, we can implement its merge strategy as follows: + -- + -- > SortedStrategy + -- > (\case; Nothing -> False; Just _ -> True) + -- > (\idx -> + -- > if idx + -- > then SimpleStrategy $ \_ t _ -> t + -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ symIte cond l r) + SortedStrategy :: + (Ord idx, Typeable idx, Show idx) => + -- | Indexing function + (a -> idx) -> + -- | Sub-strategy function + (idx -> MergingStrategy a) -> + MergingStrategy a + -- | For preventing the merging intentionally. This could be + -- useful for keeping some value concrete and may help generate more efficient + -- formulas. + -- + -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for + -- details. + NoStrategy :: MergingStrategy a + +-- | Each type is associated with a root merge strategy given by 'rootStrategy'. +-- The root merge strategy should be able to merge every value of the type. +-- Grisette will use the root merge strategy to merge the values of the type in +-- a union. +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving Mergeable via (Default X) +class Mergeable a where + -- | The root merging strategy for the type. + rootStrategy :: MergingStrategy a + +-- | Lifting of the 'Mergeable' class to unary type constructors. +class + (forall a. (Mergeable a) => Mergeable (u a)) => + Mergeable1 (u :: Type -> Type) + where + -- | Lift merge strategy through the type constructor. + liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) + +-- | Lift the root merge strategy through the unary type constructor. +rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) +rootStrategy1 = liftRootStrategy rootStrategy +{-# INLINE rootStrategy1 #-} + +-- | Workaround as GHC prior to 9.6 doesn't support quantified constraints +-- reliably. +-- +-- Similar to https://github.com/haskell/core-libraries-committee/issues/10, +-- which is only available with 9.6 or higher. +resolveMergeable1 :: + forall f a r. (Mergeable1 f, Mergeable a) => ((Mergeable (f a)) => r) -> r +resolveMergeable1 v = v + +-- | Lifting of the 'Mergeable' class to binary type constructors. +class + (forall a. (Mergeable a) => Mergeable1 (u a)) => + Mergeable2 (u :: Type -> Type -> Type) + where + -- | Lift merge strategy through the type constructor. + liftRootStrategy2 :: + MergingStrategy a -> + MergingStrategy b -> + MergingStrategy (u a b) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy2 :: + (Mergeable a, Mergeable b, Mergeable2 u) => + MergingStrategy (u a b) +rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy +{-# INLINE rootStrategy2 #-} + +-- | Lifting of the 'Mergeable' class to ternary type constructors. +class + (forall a. (Mergeable a) => Mergeable2 (u a)) => + Mergeable3 (u :: Type -> Type -> Type -> Type) + where + -- | Lift merge strategy through the type constructor. + liftRootStrategy3 :: + MergingStrategy a -> + MergingStrategy b -> + MergingStrategy c -> + MergingStrategy (u a b c) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy3 :: + (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => + MergingStrategy (u a b c) +rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy +{-# INLINE rootStrategy3 #-} + +-- | Useful utility function for building merge strategies manually. +-- +-- For example, to build the merge strategy for the just branch of @Maybe a@, +-- one could write +-- +-- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) +wrapStrategy :: + -- | The merge strategy to be wrapped + MergingStrategy a -> + -- | The wrap function + (a -> b) -> + -- | The unwrap function, which does not have to be defined for every value + (b -> a) -> + MergingStrategy b +wrapStrategy (SimpleStrategy m) wrap unwrap = + SimpleStrategy + ( \cond ifTrue ifFalse -> + wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) + ) +wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = + SortedStrategy + (idxFun . unwrap) + (\idx -> wrapStrategy (substrategy idx) wrap unwrap) +wrapStrategy NoStrategy _ _ = NoStrategy +{-# INLINE wrapStrategy #-} + +-- | Useful utility function for building merge strategies for product types +-- manually. +-- +-- For example, to build the merge strategy for the following product type, +-- one could write +-- +-- > data X = X { x1 :: Int, x2 :: Bool } +-- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy +-- > :: MergingStrategy X +product2Strategy :: + -- | The wrap function + (a -> b -> r) -> + -- | The unwrap function, which does not have to be defined for every value + (r -> (a, b)) -> + -- | The first merge strategy to be wrapped + MergingStrategy a -> + -- | The second merge strategy to be wrapped + MergingStrategy b -> + MergingStrategy r +product2Strategy wrap unwrap strategy1 strategy2 = + case (strategy1, strategy2) of + (NoStrategy, _) -> NoStrategy + (_, NoStrategy) -> NoStrategy + (SimpleStrategy m1, SimpleStrategy m2) -> + SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of + ((hdt, tlt), (hdf, tlf)) -> + wrap (m1 cond hdt hdf) (m2 cond tlt tlf) + (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> + SortedStrategy + (idxf . snd . unwrap) + (product2Strategy wrap unwrap s1 . subf) + (SortedStrategy idxf subf, s2) -> + SortedStrategy + (idxf . fst . unwrap) + (\idx -> product2Strategy wrap unwrap (subf idx) s2) +{-# INLINE product2Strategy #-} + +-- Derivations + +-- | The arguments to the generic merging strategy function. +data family MergeableArgs arity a :: Type + +data instance MergeableArgs Arity0 _ = MergeableArgs0 + +newtype instance MergeableArgs Arity1 a = MergeableArgs1 (MergingStrategy a) + +-- | The class of types that can be generically merged. +class GMergeable arity f where + grootStrategy :: MergeableArgs arity a -> MergingStrategy (f a) + +instance GMergeable arity V1 where + grootStrategy _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE grootStrategy #-} + +instance GMergeable arity U1 where + grootStrategy _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE grootStrategy #-} + +instance + (GMergeable arity a, GMergeable arity b) => + GMergeable arity (a :*: b) + where + grootStrategy args = + product2Strategy + (:*:) + (\(a :*: b) -> (a, b)) + (grootStrategy args) + (grootStrategy args) + {-# INLINE grootStrategy #-} + +instance + (GMergeable arity a, GMergeable arity b) => + GMergeable arity (a :+: b) + where + grootStrategy args = + SortedStrategy + ( \case + L1 _ -> False + R1 _ -> True + ) + ( \idx -> + if not idx + then + wrapStrategy + (grootStrategy args) + L1 + (\case (L1 v) -> v; _ -> error "Should not happen") + else + wrapStrategy + (grootStrategy args) + R1 + (\case (R1 v) -> v; _ -> error "Should not happen") + ) + {-# INLINE grootStrategy #-} + +instance (GMergeable arity a) => GMergeable arity (M1 i c a) where + grootStrategy arg = wrapStrategy (grootStrategy arg) M1 unM1 + {-# INLINE grootStrategy #-} + +instance (Mergeable c) => GMergeable arity (K1 i c) where + grootStrategy _ = wrapStrategy rootStrategy K1 unK1 + {-# INLINE grootStrategy #-} + +instance GMergeable Arity1 Par1 where + grootStrategy (MergeableArgs1 strategy) = wrapStrategy strategy Par1 unPar1 + {-# INLINE grootStrategy #-} + +instance (Mergeable1 f) => GMergeable Arity1 (Rec1 f) where + grootStrategy (MergeableArgs1 m) = + wrapStrategy (liftRootStrategy m) Rec1 unRec1 + {-# INLINE grootStrategy #-} + +instance + (Mergeable1 f, GMergeable Arity1 g) => + GMergeable Arity1 (f :.: g) + where + grootStrategy targs = + wrapStrategy (liftRootStrategy (grootStrategy targs)) Comp1 unComp1 + {-# INLINE grootStrategy #-} + +instance (Generic a, GMergeable Arity0 (Rep a)) => Mergeable (Default a) where + rootStrategy = unsafeCoerce (genericRootStrategy :: MergingStrategy a) + {-# INLINE rootStrategy #-} + +-- | Generic 'rootStrategy'. +genericRootStrategy :: + (Generic a, GMergeable Arity0 (Rep a)) => MergingStrategy a +genericRootStrategy = wrapStrategy (grootStrategy MergeableArgs0) to from +{-# INLINE genericRootStrategy #-} + +instance + (Generic1 f, GMergeable Arity1 (Rep1 f), Mergeable a) => + Mergeable (Default1 f a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Generic1 f, GMergeable Arity1 (Rep1 f)) => Mergeable1 (Default1 f) where + liftRootStrategy (m :: MergingStrategy a) = + unsafeCoerce (genericLiftRootStrategy m :: MergingStrategy (f a)) + {-# INLINE liftRootStrategy #-} + +-- | Generic 'liftRootStrategy'. +genericLiftRootStrategy :: + (Generic1 f, GMergeable Arity1 (Rep1 f)) => + MergingStrategy a -> + MergingStrategy (f a) +genericLiftRootStrategy m = + wrapStrategy (grootStrategy $ MergeableArgs1 m) to1 from1 +{-# INLINE genericLiftRootStrategy #-} + +-- | Helper type for combining arbitrary number of indices into one. +-- Useful when trying to write efficient merge strategy for lists/vectors. +data DynamicSortedIdx where + DynamicSortedIdx :: forall idx. (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' #-} + +-- | Helper type for building efficient merge strategy for list-like containers. +data StrategyList container where + StrategyList :: + forall a container. + container [DynamicSortedIdx] -> + container (MergingStrategy a) -> + StrategyList container + +-- | Helper function for building efficient merge strategy for list-like +-- containers. +buildStrategyList :: + forall a container. + (Functor container) => + MergingStrategy a -> + container a -> + StrategyList container +buildStrategyList s l = StrategyList idxs strategies + where + r = resolveStrategy s <$> l + idxs = fst <$> r + strategies = snd <$> r +{-# INLINE buildStrategyList #-} + +instance (Eq1 container) => Eq (StrategyList container) where + (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 + {-# INLINE (==) #-} + +instance (Ord1 container) => Ord (StrategyList container) where + compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 + {-# INLINE compare #-} + +instance (Show1 container) => Show (StrategyList container) where + showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 + {-# INLINE showsPrec #-} + +instance Mergeable SymBool where + rootStrategy = SimpleStrategy symIte + +instance Mergeable Ordering where + rootStrategy = + let sub = SimpleStrategy $ \_ t _ -> t + in SortedStrategy id $ const sub diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/PPrint.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/PPrint.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint + ( -- * Pretty printing + PPrint (..), + docToTextWith, + docToTextWithWidth, + docToText, + pformatTextWith, + pformatTextWithWidth, + pformatText, + pprint, + PPrint1 (..), + pformatPrec1, + pformatList1, + PPrint2 (..), + pformatPrec2, + pformatList2, + + -- * Generic 'PPrint' + genericPFormatPrec, + genericLiftPFormatPrec, + genericPFormatList, + genericLiftPFormatList, + PPrintArgs (..), + GPPrint (..), + PPrintType (..), + + -- * Helpers + groupedEnclose, + condEnclose, + pformatWithConstructor, + pformatWithConstructorNoAlign, + pformatListLike, + prettyPrintTuple, + viaShowsPrec, + + -- * Re-exports + module Prettyprinter, + ) +where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter +import Prettyprinter.Render.String (renderString) +import Prettyprinter.Render.Text (renderStrict) +#else +import Data.Text.Prettyprint.Doc as Prettyprinter +import Data.Text.Prettyprint.Doc.Render.String (renderString) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +#endif + +import Data.Kind (Type) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import GHC.Generics + ( C1, + Constructor (conFixity, conIsRecord, conName), + D1, + Fixity (Infix, Prefix), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1, unPar1), + Rec1 (Rec1, unRec1), + S1, + Selector (selName), + U1 (U1), + V1, + (:.:) (Comp1, unComp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import GHC.Stack (HasCallStack) +import Generics.Deriving (Default (unDefault), Default1 (unDefault1)) +import Grisette.Internal.SymPrim.Prim.Internal.Term () +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- | Pretty printing of values. +-- +-- This class is similar to the 'Pretty' class from the "Prettyprinter" package, +-- but it also provides pretty printing with a given precedence level. +-- +-- We are able to derive instances of this class for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving PPrint via (Default X) +-- +-- The derived instance will pretty print the value with a format similar to the +-- one used by ormolu. +class PPrint a where + pformat :: a -> Doc ann + pformatPrec :: Int -> a -> Doc ann + pformatList :: [a] -> Doc ann + pformatList = align . prettyPrintList . map pformat + + pformat = pformatPrec 0 + pformatPrec _ = pformat + + {-# MINIMAL pformat | pformatPrec #-} + +-- | Pretty print a list of documents with left and right delimiters. +pformatListLike :: Doc ann -> Doc ann -> [Doc ann] -> Doc ann +pformatListLike ldelim rdelim l + | null l = ldelim <> rdelim + | length l == 1 = + align $ group $ vcat [ldelim <> flatAlt " " "" <> head l, rdelim] + | otherwise = + groupedEnclose ldelim rdelim . align . vcat $ + ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l] + +prettyPrintList :: [Doc ann] -> Doc ann +prettyPrintList = pformatListLike "[" "]" + +-- | Pretty print a tuple. +prettyPrintTuple :: [Doc ann] -> Doc ann +prettyPrintTuple l + | length l >= 2 = + groupedEnclose "(" ")" . align . vcat $ + ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l] + | otherwise = error "Tuple must have at least 2 elements" + +instance PPrint Char where + pformat = viaShow + pformatList v = pretty (fromString v :: T.Text) + +instance (PPrint a) => PPrint [a] where + pformat = pformatList + +-- | Convenience function to layout and render a 'Doc' to 'T.Text'. +-- +-- You can control the layout with t'LayoutOptions'. +docToTextWith :: LayoutOptions -> Doc ann -> T.Text +docToTextWith options = renderStrict . layoutPretty options + +-- | Convenience function to layout and render a 'Doc' to 'T.Text'. +-- +-- You can control the layout with a single number of the width limit. +docToTextWithWidth :: Int -> Doc ann -> T.Text +docToTextWithWidth n + | n <= 0 = docToTextWith (LayoutOptions Unbounded) + | otherwise = docToTextWith (LayoutOptions $ AvailablePerLine n 1.0) + +-- | Convenience function to layout and render a 'Doc' to 'T.Text'. +-- +-- The default layout options 'defaultLayoutOptions' are used. +docToText :: Doc ann -> T.Text +docToText = docToTextWith defaultLayoutOptions + +-- | Convenience function to format a value to 'T.Text'. +-- +-- You can control the layout with t'LayoutOptions'. +pformatTextWith :: (PPrint a) => LayoutOptions -> a -> T.Text +pformatTextWith options = docToTextWith options . pformat + +-- | Convenience function to format a value to 'T.Text'. +-- +-- You can control the layout with a single number of the width limit. +pformatTextWithWidth :: (PPrint a) => Int -> a -> T.Text +pformatTextWithWidth n = docToTextWithWidth n . pformat + +-- | Convenience function to format a value to 'T.Text'. +-- +-- The default layout options 'defaultLayoutOptions' are used. +pformatText :: (PPrint a) => a -> T.Text +pformatText = docToText . pformat + +-- | Pretty print a value to the standard output. +pprint :: (PPrint a) => a -> IO () +pprint = putStrLn . renderString . layoutPretty defaultLayoutOptions . pformat + +-- | Lifting of the 'PPrint' class to unary type constructors. +class (forall a. (PPrint a) => PPrint (f a)) => PPrint1 f where + -- | Lift a pretty-printer to a unary type constructor. + liftPFormatPrec :: + (Int -> a -> Doc ann) -> ([a] -> Doc ann) -> Int -> f a -> Doc ann + + -- | Lift a pretty-printer to list of values with unary type constructors. + liftPFormatList :: + (Int -> a -> Doc ann) -> ([a] -> Doc ann) -> [f a] -> Doc ann + liftPFormatList f l = align . prettyPrintList . map (liftPFormatPrec f l 0) + +instance PPrint1 [] where + liftPFormatPrec _ l _ = l + liftPFormatList _ l = prettyPrintList . fmap l + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to unary +-- type constructors. +pformatPrec1 :: (PPrint1 f, PPrint a) => Int -> f a -> Doc ann +pformatPrec1 = liftPFormatPrec pformatPrec pformatList +{-# INLINE pformatPrec1 #-} + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to list of +-- values with unary type constructors. +pformatList1 :: (PPrint1 f, PPrint a) => [f a] -> Doc ann +pformatList1 = liftPFormatList pformatPrec pformatList +{-# INLINE pformatList1 #-} + +-- | Lifting of the 'PPrint' class to binary type constructors. +class + ( forall a. (PPrint a) => PPrint1 (f a), + forall a b. (PPrint a, PPrint b) => PPrint (f a b) + ) => + PPrint2 f + where + -- | Lift two pretty-printers to a binary type constructor. + liftPFormatPrec2 :: + (Int -> a -> Doc ann) -> + ([a] -> Doc ann) -> + (Int -> b -> Doc ann) -> + ([b] -> Doc ann) -> + Int -> + f a b -> + Doc ann + + -- | Lift two pretty-printers to list of values with binary type constructors. + liftPFormatList2 :: + (Int -> a -> Doc ann) -> + ([a] -> Doc ann) -> + (Int -> b -> Doc ann) -> + ([b] -> Doc ann) -> + [f a b] -> + Doc ann + liftPFormatList2 fa fb la lb = + align . prettyPrintList . map (liftPFormatPrec2 fa fb la lb 0) + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to binary +-- type constructors. +pformatPrec2 :: (PPrint2 f, PPrint a, PPrint b) => Int -> f a b -> Doc ann +pformatPrec2 = liftPFormatPrec2 pformatPrec pformatList pformatPrec pformatList +{-# INLINE pformatPrec2 #-} + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to list of +-- values with binary type constructors. +pformatList2 :: (PPrint2 f, PPrint a, PPrint b) => [f a b] -> Doc ann +pformatList2 = liftPFormatList2 pformatPrec pformatList pformatPrec pformatList +{-# INLINE pformatList2 #-} + +-- | The arguments to the generic 'PPrint' class. +data family PPrintArgs arity a ann :: Type + +data instance PPrintArgs Arity0 _ _ = PPrintArgs0 + +data instance PPrintArgs Arity1 a ann + = PPrintArgs1 + ((Int -> a -> Doc ann)) + (([a] -> Doc ann)) + +-- | Controls how to pretty-print a generic representation. +data PPrintType = Rec | Tup | Pref | Inf String Int + deriving (Show, Eq) + +-- | Enclose a document with left and right documents. +-- +-- The pretty printer will try to layout the document in a single line, but the +-- right document may be split to a newline. +groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann +groupedEnclose l r d = group $ align $ vcat [l <> flatAlt " " "" <> align d, r] + +-- | Conditionally enclose a document with left and right documents. +-- +-- If the condition is 'True', then this function is equivalent to +-- 'groupedEnclose'. +condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann +condEnclose b = if b then groupedEnclose else const $ const id + +-- | Pretty print a list of fields with a constructor. +-- +-- Aligns the fields and nests them by 2 spaces. +pformatWithConstructor :: Int -> Doc ann -> [Doc ann] -> Doc ann +pformatWithConstructor n c l = + group $ condEnclose (n > 10) "(" ")" $ align $ nest 2 $ vsep (c : l) + +-- | Pretty print a list of fields with a constructor without alignment. +pformatWithConstructorNoAlign :: Int -> Doc ann -> [Doc ann] -> Doc ann +pformatWithConstructorNoAlign n c l = + group $ condEnclose (n > 10) "(" ")" $ nest 2 $ vsep (c : l) + +-- | Pretty print a value using 'showsPrec'. +viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann +viaShowsPrec f n a = pretty (f n a "") + +-- | Generic 'PPrint' class. +class GPPrint arity f where + gpformatPrec :: PPrintArgs arity a ann -> PPrintType -> Int -> f a -> Doc ann + gpformatList :: (HasCallStack) => PPrintArgs arity a ann -> [f a] -> Doc ann + gpformatList = error "generic format (gpformatList): unnecessary case" + gisNullary :: (HasCallStack) => PPrintArgs arity a ann -> f a -> Bool + gisNullary = error "generic format (isNullary): unnecessary case" + +instance GPPrint arity V1 where + gpformatPrec _ _ _ x = case x of {} + +instance GPPrint arity U1 where + gpformatPrec _ _ _ U1 = "" + gisNullary _ _ = True + +instance (PPrint c) => GPPrint arity (K1 i c) where + gpformatPrec _ _ n (K1 a) = pformatPrec n a + gisNullary _ _ = False + +instance (GPPrint arity a, Constructor c) => GPPrint arity (C1 c a) where + gpformatPrec arg _ n c@(M1 x) = + case t of + Tup -> + prettyBraces t (gpformatPrec arg t 0 x) + Inf _ m -> + group $ condEnclose (n > m) "(" ")" $ gpformatPrec arg t m x + _ -> + if gisNullary arg x + then pformat (conName c) + else + pformatWithConstructorNoAlign + n + (pformat (conName c)) + [prettyBraces t (gpformatPrec arg t 11 x)] + where + prettyBraces :: PPrintType -> Doc ann -> Doc ann + prettyBraces Rec = groupedEnclose "{" "}" + prettyBraces Tup = groupedEnclose "(" ")" + prettyBraces Pref = id + prettyBraces (Inf _ _) = id + fixity = conFixity c + t + | conIsRecord c = Rec + | conIsTuple c = Tup + | otherwise = case fixity of + Prefix -> Pref + Infix _ i -> Inf (conName c) i + conIsTuple :: C1 c f p -> Bool + conIsTuple y = tupleName (conName y) + where + tupleName ('(' : ',' : _) = True + tupleName _ = False + +instance (Selector s, GPPrint arity a) => GPPrint arity (S1 s a) where + gpformatPrec arg t n s@(M1 x) + | selName s == "" = + case t of + Pref -> gpformatPrec arg t (n + 1) x + _ -> gpformatPrec arg t (n + 1) x + | otherwise = + group $ + align $ + nest 2 $ + vsep [pretty (selName s) <+> "=", gpformatPrec arg t 0 x] + gisNullary _ _ = False + +instance (GPPrint arity a) => GPPrint arity (D1 d a) where + gpformatPrec arg _ n (M1 x) = gpformatPrec arg Pref n x + gpformatList arg = align . prettyPrintList . fmap (gpformatPrec arg Pref 0) + +instance (GPPrint arity a, GPPrint arity b) => GPPrint arity (a :+: b) where + gpformatPrec arg t n (L1 x) = gpformatPrec arg t n x + gpformatPrec arg t n (R1 x) = gpformatPrec arg t n x + +instance (GPPrint arity a, GPPrint arity b) => GPPrint arity (a :*: b) where + gpformatPrec arg t@Rec n (a :*: b) = + align $ + vcat + [ gpformatPrec arg t n a <> "," <> flatAlt "" " ", + gpformatPrec arg t n b + ] + gpformatPrec arg t@(Inf s _) n (a :*: b) = + nest 2 $ + vsep + [ align $ gpformatPrec arg t n a, + pretty s <+> gpformatPrec arg t n b + ] + gpformatPrec arg t@Tup _ (a :*: b) = + vcat + [ gpformatPrec arg t 0 a <> "," <> flatAlt "" " ", + gpformatPrec arg t 0 b + ] + gpformatPrec arg t@Pref n (a :*: b) = + vsep + [ gpformatPrec arg t (n + 1) a, + gpformatPrec arg t (n + 1) b + ] + gisNullary _ _ = False + +instance GPPrint Arity1 Par1 where + gpformatPrec (PPrintArgs1 f _) _ n (Par1 a) = f n a + gpformatList (PPrintArgs1 _ g) l = g $ unPar1 <$> l + +instance (PPrint1 f) => GPPrint Arity1 (Rec1 f) where + gpformatPrec (PPrintArgs1 f g) _ n (Rec1 x) = liftPFormatPrec f g n x + gpformatList (PPrintArgs1 f g) l = liftPFormatList f g $ unRec1 <$> l + +instance + (PPrint1 f, GPPrint Arity1 g) => + GPPrint Arity1 (f :.: g) + where + gpformatPrec arg t n (Comp1 x) = + liftPFormatPrec (gpformatPrec arg t) (gpformatList arg) n x + gpformatList arg l = + liftPFormatList (gpformatPrec arg Pref) (gpformatList arg) $ unComp1 <$> l + +-- | Generic 'pformatPrec' function. +genericPFormatPrec :: + (Generic a, GPPrint Arity0 (Rep a)) => + Int -> + a -> + Doc ann +genericPFormatPrec n = gpformatPrec PPrintArgs0 Pref n . from +{-# INLINE genericPFormatPrec #-} + +-- | Generic 'pformatList' function. +genericPFormatList :: + (Generic a, GPPrint Arity0 (Rep a)) => + [a] -> + Doc ann +genericPFormatList = gpformatList PPrintArgs0 . fmap from +{-# INLINE genericPFormatList #-} + +-- | Generic 'liftPFormatPrec' function. +genericLiftPFormatPrec :: + (Generic1 f, GPPrint Arity1 (Rep1 f)) => + (Int -> a -> Doc ann) -> + ([a] -> Doc ann) -> + Int -> + f a -> + Doc ann +genericLiftPFormatPrec p l n = gpformatPrec (PPrintArgs1 p l) Pref n . from1 +{-# INLINE genericLiftPFormatPrec #-} + +-- | Generic 'liftPFormatList' function. +genericLiftPFormatList :: + (Generic1 f, GPPrint Arity1 (Rep1 f)) => + (Int -> a -> Doc ann) -> + ([a] -> Doc ann) -> + [f a] -> + Doc ann +genericLiftPFormatList p l = gpformatList (PPrintArgs1 p l) . fmap from1 +{-# INLINE genericLiftPFormatList #-} + +instance + (Generic a, GPPrint Arity0 (Rep a)) => + PPrint (Default a) + where + pformatPrec n = genericPFormatPrec n . unDefault + pformatList = genericPFormatList . fmap unDefault + +instance + (Generic1 f, GPPrint Arity1 (Rep1 f), PPrint a) => + PPrint (Default1 f a) + where + pformatPrec = pformatPrec1 + pformatList = pformatList1 + +instance + (Generic1 f, GPPrint Arity1 (Rep1 f)) => + PPrint1 (Default1 f) + where + liftPFormatPrec p l n = genericLiftPFormatPrec p l n . unDefault1 + liftPFormatList p l = genericLiftPFormatList p l . fmap unDefault1 diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SafeDiv.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SafeDiv.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SafeDiv.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv + ( ArithException (..), + SafeDiv (..), + DivOr (..), + divOrZero, + modOrDividend, + quotOrZero, + remOrDividend, + divModOrZeroDividend, + quotRemOrZeroDividend, + ) +where + +import Control.Exception (ArithException (DivideByZero, Overflow, Underflow)) +import Control.Monad.Except (MonadError) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + ) +import Grisette.Lib.Data.Functor (mrgFmap) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Except +-- >>> import Control.Exception + +-- | Safe division handling with default values returned on exception. +class DivOr a where + -- | Safe 'div' with default value returned on exception. + -- + -- >>> divOr "d" "a" "b" :: SymInteger + -- (ite (= b 0) d (div a b)) + divOr :: a -> a -> a -> a + + -- | Safe 'mod' with default value returned on exception. + -- + -- >>> modOr "d" "a" "b" :: SymInteger + -- (ite (= b 0) d (mod a b)) + modOr :: a -> a -> a -> a + + -- | Safe 'divMod' with default value returned on exception. + -- + -- >>> divModOr ("d", "m") "a" "b" :: (SymInteger, SymInteger) + -- ((ite (= b 0) d (div a b)),(ite (= b 0) m (mod a b))) + divModOr :: (a, a) -> a -> a -> (a, a) + + -- | Safe 'quot' with default value returned on exception. + quotOr :: a -> a -> a -> a + + -- | Safe 'rem' with default value returned on exception. + remOr :: a -> a -> a -> a + + -- | Safe 'quotRem' with default value returned on exception. + quotRemOr :: (a, a) -> a -> a -> (a, a) + +-- | Safe 'div' with 0 returned on exception. +divOrZero :: (DivOr a, Num a) => a -> a -> a +divOrZero l = divOr (l - l) l +{-# INLINE divOrZero #-} + +-- | Safe 'mod' with dividend returned on exception. +modOrDividend :: (DivOr a, Num a) => a -> a -> a +modOrDividend l = modOr l l +{-# INLINE modOrDividend #-} + +-- | Safe 'quot' with 0 returned on exception. +quotOrZero :: (DivOr a, Num a) => a -> a -> a +quotOrZero l = quotOr (l - l) l +{-# INLINE quotOrZero #-} + +-- | Safe 'rem' with dividend returned on exception. +remOrDividend :: (DivOr a, Num a) => a -> a -> a +remOrDividend l = remOr l l +{-# INLINE remOrDividend #-} + +-- | Safe 'divMod' with 0 returned on exception. +divModOrZeroDividend :: (DivOr a, Num a) => a -> a -> (a, a) +divModOrZeroDividend l = divModOr (l - l, l) l +{-# INLINE divModOrZeroDividend #-} + +-- | Safe 'quotRem' with 0 returned on exception. +quotRemOrZeroDividend :: (DivOr a, Num a) => a -> a -> (a, a) +quotRemOrZeroDividend l = quotRemOr (l - l, l) l +{-# INLINE quotRemOrZeroDividend #-} + +-- | Safe division with monadic error handling in multi-path +-- execution. These procedures throw an exception when the +-- divisor is zero. The result should be able to handle errors with +-- `MonadError`. +class (MonadError e m, TryMerge m, Mergeable a, DivOr a) => SafeDiv e a m where + -- | Safe 'div' with monadic error handling in multi-path execution. + -- + -- >>> safeDiv "a" "b" :: ExceptT ArithException Union SymInteger + -- ExceptT {If (= b 0) (Left divide by zero) (Right (div a b))} + safeDiv :: a -> a -> m a + safeDiv l r = mrgFmap fst $ safeDivMod l r + {-# INLINE safeDiv #-} + + -- | Safe 'mod' with monadic error handling in multi-path execution. + -- + -- >>> safeMod "a" "b" :: ExceptT ArithException Union SymInteger + -- ExceptT {If (= b 0) (Left divide by zero) (Right (mod a b))} + safeMod :: a -> a -> m a + safeMod l r = mrgFmap snd $ safeDivMod l r + {-# INLINE safeMod #-} + + -- | Safe 'divMod' with monadic error handling in multi-path execution. + -- + -- >>> safeDivMod "a" "b" :: ExceptT ArithException Union (SymInteger, SymInteger) + -- ExceptT {If (= b 0) (Left divide by zero) (Right ((div a b),(mod a b)))} + safeDivMod :: a -> a -> m (a, a) + safeDivMod l r = do + d <- safeDiv l r + m <- safeMod l r + mrgSingle (d, m) + {-# INLINE safeDivMod #-} + + -- | Safe 'quot' with monadic error handling in multi-path execution. + safeQuot :: a -> a -> m a + safeQuot l r = mrgFmap fst $ safeQuotRem l r + {-# INLINE safeQuot #-} + + -- | Safe 'rem' with monadic error handling in multi-path execution. + safeRem :: a -> a -> m a + safeRem l r = mrgFmap snd $ safeQuotRem l r + {-# INLINE safeRem #-} + + -- | Safe 'quotRem' with monadic error handling in multi-path execution. + safeQuotRem :: a -> a -> m (a, a) + safeQuotRem l r = do + q <- safeQuot l r + m <- safeRem l r + mrgSingle (q, m) + {-# INLINE safeQuotRem #-} + + {-# MINIMAL + ((safeDiv, safeMod) | safeDivMod), + ((safeQuot, safeRem) | safeQuotRem) + #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SimpleMergeable.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( -- * Simple mergeable types + SimpleMergeable (..), + SimpleMergeable1 (..), + mrgIte1, + SimpleMergeable2 (..), + mrgIte2, + + -- * Generic 'SimpleMergeable' + SimpleMergeableArgs (..), + GSimpleMergeable (..), + genericMrgIte, + genericLiftMrgIte, + + -- * Symbolic branching + SymBranching (..), + mrgIf, + mergeWithStrategy, + merge, + ) +where + +import Data.Kind (Type) +import GHC.Generics + ( Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + ) +import Generics.Deriving (Default (Default), Default1 (Default1)) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( GMergeable, + Mergeable (rootStrategy), + Mergeable1, + Mergeable2, + MergingStrategy, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Identity + +-- | This class indicates that a type has a simple root merge strategy. +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... +-- > deriving Generic +-- > deriving (Mergeable, SimpleMergeable) via (Default X) +class (Mergeable a) => SimpleMergeable a where + -- | Performs if-then-else with the simple root merge strategy. + -- + -- >>> mrgIte "a" "b" "c" :: SymInteger + -- (ite a b c) + mrgIte :: SymBool -> a -> a -> a + +-- | Lifting of the 'SimpleMergeable' class to unary type constructors. +class + (Mergeable1 u, forall a. (SimpleMergeable a) => (SimpleMergeable (u a))) => + SimpleMergeable1 u + where + -- | Lift 'mrgIte' through the type constructor. + -- + -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger + -- Identity (ite a b c) + liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a + +-- | Lift the standard 'mrgIte' function through the type constructor. +-- +-- >>> mrgIte1 "a" (Identity "b") (Identity "c") :: Identity SymInteger +-- Identity (ite a b c) +mrgIte1 :: + (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a +mrgIte1 = liftMrgIte mrgIte +{-# INLINE mrgIte1 #-} + +-- | Lifting of the 'SimpleMergeable' class to binary type constructors. +class + (Mergeable2 u, forall a. (SimpleMergeable a) => SimpleMergeable1 (u a)) => + SimpleMergeable2 u + where + -- | Lift 'mrgIte' through the type constructor. + -- + -- >>> liftMrgIte2 mrgIte mrgIte "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) + -- ((ite a b d),(ite a c e)) + liftMrgIte2 :: + (SymBool -> a -> a -> a) -> + (SymBool -> b -> b -> b) -> + SymBool -> + u a b -> + u a b -> + u a b + +-- | Lift the standard 'mrgIte' function through the type constructor. +-- +-- >>> mrgIte2 "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) +-- ((ite a b d),(ite a c e)) +mrgIte2 :: + (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => + SymBool -> + u a b -> + u a b -> + u a b +mrgIte2 = liftMrgIte2 mrgIte mrgIte +{-# INLINE mrgIte2 #-} + +-- | The arguments to the generic simple merging function. +data family SimpleMergeableArgs arity a :: Type + +data instance SimpleMergeableArgs Arity0 _ = SimpleMergeableArgs0 + +newtype instance SimpleMergeableArgs Arity1 a + = SimpleMergeableArgs1 (SymBool -> a -> a -> a) + +-- | Generic 'SimpleMergeable' class. +class GSimpleMergeable arity f where + gmrgIte :: SimpleMergeableArgs arity a -> SymBool -> f a -> f a -> f a + +instance GSimpleMergeable arity V1 where + gmrgIte _ _ t _ = t + {-# INLINE gmrgIte #-} + +instance (GSimpleMergeable arity U1) where + gmrgIte _ _ t _ = t + {-# INLINE gmrgIte #-} + +instance + (GSimpleMergeable arity a, GSimpleMergeable arity b) => + (GSimpleMergeable arity (a :*: b)) + where + gmrgIte args cond (a1 :*: a2) (b1 :*: b2) = + gmrgIte args cond a1 b1 :*: gmrgIte args cond a2 b2 + {-# INLINE gmrgIte #-} + +instance (GSimpleMergeable arity a) => (GSimpleMergeable arity (M1 i c a)) where + gmrgIte args cond (M1 a) (M1 b) = M1 $ gmrgIte args cond a b + {-# INLINE gmrgIte #-} + +instance (SimpleMergeable c) => (GSimpleMergeable arity (K1 i c)) where + gmrgIte _ cond (K1 a) (K1 b) = K1 $ mrgIte cond a b + {-# INLINE gmrgIte #-} + +instance GSimpleMergeable Arity1 Par1 where + gmrgIte (SimpleMergeableArgs1 f) cond (Par1 l) (Par1 r) = Par1 $ f cond l r + {-# INLINE gmrgIte #-} + +instance (SimpleMergeable1 f) => GSimpleMergeable Arity1 (Rec1 f) where + gmrgIte (SimpleMergeableArgs1 f) cond (Rec1 l) (Rec1 r) = + Rec1 $ liftMrgIte f cond l r + {-# INLINE gmrgIte #-} + +instance + (SimpleMergeable1 f, GSimpleMergeable Arity1 g) => + GSimpleMergeable Arity1 (f :.: g) + where + gmrgIte targs cond (Comp1 l) (Comp1 r) = + Comp1 $ liftMrgIte (gmrgIte targs) cond l r + {-# INLINE gmrgIte #-} + +instance + (Generic a, GSimpleMergeable Arity0 (Rep a), GMergeable Arity0 (Rep a)) => + SimpleMergeable (Default a) + where + mrgIte cond (Default a) (Default b) = + Default $ genericMrgIte cond a b + {-# INLINE mrgIte #-} + +-- | Generic 'mrgIte' function. +genericMrgIte :: + (Generic a, GSimpleMergeable Arity0 (Rep a)) => + SymBool -> + a -> + a -> + a +genericMrgIte cond a b = + to $ gmrgIte SimpleMergeableArgs0 cond (from a) (from b) +{-# INLINE genericMrgIte #-} + +instance + ( Generic1 f, + GSimpleMergeable Arity1 (Rep1 f), + GMergeable Arity1 (Rep1 f), + SimpleMergeable a + ) => + SimpleMergeable (Default1 f a) + where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance + (Generic1 f, GSimpleMergeable Arity1 (Rep1 f), GMergeable Arity1 (Rep1 f)) => + SimpleMergeable1 (Default1 f) + where + liftMrgIte f c (Default1 l) (Default1 r) = + Default1 $ genericLiftMrgIte f c l r + {-# INLINE liftMrgIte #-} + +-- | Generic 'liftMrgIte' function. +genericLiftMrgIte :: + (Generic1 f, GSimpleMergeable Arity1 (Rep1 f)) => + (SymBool -> a -> a -> a) -> + SymBool -> + f a -> + f a -> + f a +genericLiftMrgIte f c l r = + to1 $ gmrgIte (SimpleMergeableArgs1 f) c (from1 l) (from1 r) +{-# INLINE genericLiftMrgIte #-} + +-- | Special case of the 'Mergeable1' and 'SimpleMergeable1' class for type +-- constructors that are 'SimpleMergeable' when applied to any 'Mergeable' +-- types. +-- +-- This type class is used to generalize the 'mrgIf' function to other +-- containers, for example, monad transformer transformed Unions. +class + ( SimpleMergeable1 u, + forall a. (Mergeable a) => SimpleMergeable (u a), + TryMerge u + ) => + SymBranching (u :: Type -> Type) + where + -- | Symbolic @if@ control flow with the result merged with some merge + -- strategy. + -- + -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (return "c") :: Union SymInteger + -- {(ite a b c)} + -- + -- __Note:__ Be careful to call this directly in your code. + -- The supplied merge strategy should be consistent with the type's root merge + -- strategy, or some internal invariants would be broken and the program can + -- crash. + -- + -- This function is to be called when the 'Mergeable' constraint can not be + -- resolved, e.g., the merge strategy for the contained type is given with + -- 'Mergeable1'. In other cases, 'mrgIf' is usually a better alternative. + mrgIfWithStrategy :: MergingStrategy a -> SymBool -> u a -> u a -> u a + + -- | Symbolic @if@ control flow with the result. + -- + -- This function does not need a merging strategy, and it will merge the + -- result only if any of the branches is merged. + mrgIfPropagatedStrategy :: SymBool -> u a -> u a -> u a + +-- | Try to merge the container with a given merge strategy. +mergeWithStrategy :: (SymBranching m) => MergingStrategy a -> m a -> m a +mergeWithStrategy = tryMergeWithStrategy +{-# INLINE mergeWithStrategy #-} + +-- | Try to merge the container with the root strategy. +merge :: (SymBranching m, Mergeable a) => m a -> m a +merge = mergeWithStrategy rootStrategy +{-# INLINE merge #-} + +-- | Symbolic @if@ control flow with the result merged with the type's root +-- merge strategy. +-- +-- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@. +-- +-- >>> mrgIf "a" (return "b") (return "c") :: Union SymInteger +-- {(ite a b c)} +mrgIf :: (SymBranching u, Mergeable a) => SymBool -> u a -> u a -> u a +mrgIf = mrgIfWithStrategy rootStrategy +{-# INLINE mrgIf #-} + +instance SimpleMergeable SymBool where + mrgIte = symIte + {-# INLINE mrgIte #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/Solver.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/Solver.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.Solver +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.Solver + ( -- * Note for the examples + + -- + + -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3) + -- solver is available in @PATH@. + + -- * Solver interfaces + SolvingFailure (..), + MonadicSolver (..), + monadicSolverSolve, + SolverCommand (..), + ConfigurableSolver (..), + Solver (..), + solverSolve, + withSolver, + solve, + solverSolveMulti, + solveMulti, + + -- * Union with exceptions + UnionWithExcept (..), + solverSolveExcept, + solveExcept, + solverSolveMultiExcept, + solveMultiExcept, + ) +where + +import Control.DeepSeq (NFData) +import Control.Exception (mask, onException) +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.HashSet as S +import Data.Hashable (Hashable) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (extractSym), + ) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion, + simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.Prim.Model + ( AnySymbolSet, + Model, + SymbolSet (unSymbolSet), + equation, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( SomeTypedSymbol (SomeTypedSymbol), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Language.Haskell.TH.Syntax (Lift) + +data SolveInternal = SolveInternal + deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData) + +-- $setup +-- >>> import Grisette +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend + +-- | The current failures that can be returned by the solver. +data SolvingFailure + = -- | Unsatisfiable: No model is available. + Unsat + | -- | Unknown: The solver cannot determine whether the formula is + -- satisfiable. + Unk + | -- | The solver has reached the maximum number of models to return. + ResultNumLimitReached + | -- | The solver has encountered an error. + SolvingError T.Text + | -- | The solver has been terminated. + Terminated + deriving (Lift) + +-- | A monadic solver interface. +-- +-- This interface abstract the monadic interface of a solver. All the operations +-- performed in the monad are using a single solver instance. The solver +-- instance is management by the monad's @run@ function. +class (Monad m) => MonadicSolver m where + monadicSolverPush :: Int -> m () + monadicSolverPop :: Int -> m () + monadicSolverResetAssertions :: m () + monadicSolverAssert :: SymBool -> m () + monadicSolverCheckSat :: m (Either SolvingFailure Model) + +-- | Solve a single formula with a monadic solver. Find an assignment to it to +-- make it true. +monadicSolverSolve :: + (MonadicSolver m) => SymBool -> m (Either SolvingFailure Model) +monadicSolverSolve formula = do + monadicSolverAssert formula + monadicSolverCheckSat + +-- | The commands that can be sent to a solver. +data SolverCommand + = SolverAssert !SymBool + | SolverCheckSat + | SolverPush Int + | SolverPop Int + | SolverResetAssertions + | SolverTerminate + +-- | A class that abstracts the solver interface. +class Solver handle where + -- | Run a solver command. + solverRunCommand :: + (handle -> IO (Either SolvingFailure a)) -> + handle -> + SolverCommand -> + IO (Either SolvingFailure a) + + -- | Assert a formula. + solverAssert :: handle -> SymBool -> IO (Either SolvingFailure ()) + solverAssert handle formula = + solverRunCommand (const $ return $ Right ()) handle $ SolverAssert formula + + -- | Solve a formula. + solverCheckSat :: handle -> IO (Either SolvingFailure Model) + + -- | Push @n@ levels. + solverPush :: handle -> Int -> IO (Either SolvingFailure ()) + solverPush handle n = + solverRunCommand (const $ return $ Right ()) handle $ SolverPush n + + -- | Pop @n@ levels. + solverPop :: handle -> Int -> IO (Either SolvingFailure ()) + solverPop handle n = + solverRunCommand (const $ return $ Right ()) handle $ SolverPop n + + -- | Reset all assertions in the solver. + -- + -- The solver keeps all the assertions used in the previous commands: + -- + -- >>> solver <- newSolver z3 + -- >>> solverSolve solver "a" + -- Right (Model {a -> true :: Bool}) + -- >>> solverSolve solver $ symNot "a" + -- Left Unsat + -- + -- You can clear the assertions using @solverResetAssertions@: + -- + -- >>> solverResetAssertions solver + -- Right () + -- >>> solverSolve solver $ symNot "a" + -- Right (Model {a -> false :: Bool}) + solverResetAssertions :: handle -> IO (Either SolvingFailure ()) + solverResetAssertions handle = + solverRunCommand (const $ return $ Right ()) handle SolverResetAssertions + + -- | Terminate the solver, wait until the last command is finished. + solverTerminate :: handle -> IO () + + -- | Force terminate the solver, do not wait for the last command to finish. + solverForceTerminate :: handle -> IO () + +-- | Solve a single formula. Find an assignment to it to make it true. +solverSolve :: + (Solver handle) => handle -> SymBool -> IO (Either SolvingFailure Model) +solverSolve solver formula = do + res <- solverAssert solver formula + case res of + Left err -> return $ Left err + Right _ -> solverCheckSat solver + +-- | Solve a single formula while returning multiple models to make it true. +-- The maximum number of desired models are given. +solverSolveMulti :: + (Solver handle) => + -- | solver handle + handle -> + -- | maximum number of models to return + Int -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO ([Model], SolvingFailure) +solverSolveMulti solver numOfModelRequested formula = do + firstModel <- solverSolve solver formula + case firstModel of + Left err -> return ([], err) + Right model -> do + (models, err) <- go solver model numOfModelRequested + return (model : models, err) + where + allSymbols = extractSym formula :: AnySymbolSet + go solver prevModel n + | n <= 1 = return ([], ResultNumLimitReached) + | otherwise = do + let newFormula = + S.foldl' + ( \acc (SomeTypedSymbol v) -> + acc + .|| (symNot (SymBool $ fromJust $ equation v prevModel)) + ) + (con False) + (unSymbolSet allSymbols) + res <- solverSolve solver newFormula + case res of + Left err -> return ([], err) + Right model -> do + (models, err) <- go solver model (n - 1) + return (model : models, err) + +-- | +-- Solver procedure for programs with error handling. +solverSolveExcept :: + ( UnionWithExcept t u e v, + PlainUnion u, + Functor u, + Solver handle + ) => + -- | solver handle + handle -> + -- | mapping the results to symbolic boolean formulas, the solver would try to + -- find a model to make the formula true + (Either e v -> SymBool) -> + -- | the program to be solved, should be a union of exception and values + t -> + IO (Either SolvingFailure Model) +solverSolveExcept solver f v = + solverSolve solver (simpleMerge $ f <$> extractUnionExcept v) + +-- | +-- Solver procedure for programs with error handling. Would return multiple +-- models if possible. +solverSolveMultiExcept :: + ( UnionWithExcept t u e v, + PlainUnion u, + Functor u, + Solver handle + ) => + -- | solver configuration + handle -> + -- | maximum number of models to return + Int -> + -- | mapping the results to symbolic boolean formulas, the solver would try to + -- find a model to make the formula true + (Either e v -> SymBool) -> + -- | the program to be solved, should be a union of exception and values + t -> + IO ([Model], SolvingFailure) +solverSolveMultiExcept handle n f v = + solverSolveMulti handle n (simpleMerge $ f <$> extractUnionExcept v) + +-- | A class that abstracts the creation of a solver instance based on a +-- configuration. +-- +-- The solver instance will need to be terminated by the user, with the solver +-- interface. +class + (Solver handle) => + ConfigurableSolver config handle + | config -> handle + where + newSolver :: config -> IO handle + +-- | Start a solver, run a computation with the solver, and terminate the +-- solver after the computation finishes. +-- +-- When an exception happens, this will forcibly terminate the solver. +-- +-- Note: if Grisette is compiled with sbv < 10.10, the solver likely won't be +-- really terminated until it has finished the last action, and this will +-- result in long-running or zombie solver instances. +-- +-- This was due to a bug in sbv, which is fixed in +-- https://github.com/LeventErkok/sbv/pull/695. +withSolver :: + (ConfigurableSolver config handle) => + config -> + (handle -> IO a) -> + IO a +withSolver config action = + mask $ \restore -> do + handle <- newSolver config + r <- restore (action handle) `onException` solverForceTerminate handle + solverTerminate handle + return r + +-- | Solve a single formula. Find an assignment to it to make it true. +-- +-- >>> solve z3 ("a" .&& ("b" :: SymInteger) .== 1) +-- Right (Model {a -> true :: Bool, b -> 1 :: Integer}) +-- >>> solve z3 ("a" .&& symNot "a") +-- Left Unsat +solve :: + (ConfigurableSolver config handle) => + -- | solver configuration + config -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO (Either SolvingFailure Model) +solve config formula = withSolver config (`solverSolve` formula) + +-- | Solve a single formula while returning multiple models to make it true. +-- The maximum number of desired models are given. +-- +-- > >>> solveMulti z3 4 ("a" .|| "b") +-- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] +solveMulti :: + (ConfigurableSolver config handle) => + -- | solver configuration + config -> + -- | maximum number of models to return + Int -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO ([Model], SolvingFailure) +solveMulti config numOfModelRequested formula = + withSolver config $ + \solver -> solverSolveMulti solver numOfModelRequested formula + +-- | A class that abstracts the union-like structures that contains exceptions. +class UnionWithExcept t u e v | t -> u e v where + -- | Extract a union of exceptions and values from the structure. + extractUnionExcept :: t -> u (Either e v) + +instance UnionWithExcept (ExceptT e u v) u e v where + extractUnionExcept = runExceptT + +-- | +-- Solver procedure for programs with error handling. +-- +-- >>> import Control.Monad.Except +-- >>> let x = "x" :: SymInteger +-- >>> :{ +-- res :: ExceptT AssertionError Union () +-- res = do +-- symAssert $ x .> 0 -- constrain that x is positive +-- symAssert $ x .< 2 -- constrain that x is less than 2 +-- :} +-- +-- >>> :{ +-- translate (Left _) = con False -- errors are not desirable +-- translate _ = con True -- non-errors are desirable +-- :} +-- +-- >>> solveExcept z3 translate res +-- Right (Model {x -> 1 :: Integer}) +solveExcept :: + ( UnionWithExcept t u e v, + 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 = + withSolver config $ + \solver -> solverSolveExcept solver f v + +-- | +-- Solver procedure for programs with error handling. Would return multiple +-- models if possible. +solveMultiExcept :: + ( UnionWithExcept t u e v, + 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 = + withSolver config $ + \solver -> solverSolveMultiExcept solver n f v diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SubstSym.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SubstSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SubstSym.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym + ( -- * Substituting symbolic constants + SubstSym (..), + SubstSym1 (..), + substSym1, + SubstSym2 (..), + substSym2, + + -- * Generic 'SubstSym' + SubstSymArgs (..), + GSubstSym (..), + genericSubstSym, + genericLiftSubstSym, + ) +where + +import Data.Kind (Type) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving.Instances () +import Grisette.Internal.SymPrim.Prim.Term + ( IsSymbolKind, + LinkedRep, + SymbolKind, + TypedSymbol, + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Substitution of symbols (symbolic constants) to a symbolic value. +-- +-- >>> a = "a" :: TypedAnySymbol Bool +-- >>> v = "x" .&& "y" :: SymBool +-- >>> substSym a v (["a" .&& "b", "a"] :: [SymBool]) +-- [(&& (&& x y) b),(&& x y)] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SubstSym via (Default X) +class SubstSym a where + -- Substitute a symbolic constant to some symbolic value + -- + -- >>> substSym "a" ("c" .&& "d" :: Sym Bool) ["a" .&& "b" :: Sym Bool, "a"] + -- [(&& (&& c d) b),(&& c d)] + substSym :: + (LinkedRep cb sb, IsSymbolKind knd) => + TypedSymbol knd cb -> + sb -> + a -> + a + +-- | Lifting of 'SubstSym' to unary type constructors. +class + (forall a. (SubstSym a) => SubstSym (f a)) => + SubstSym1 f + where + -- | Lift a symbol substitution function to unary type constructors. + liftSubstSym :: + (LinkedRep cb sb, IsSymbolKind knd) => + (TypedSymbol knd cb -> sb -> a -> a) -> + TypedSymbol knd cb -> + sb -> + f a -> + f a + +-- | Lifting the standard 'substSym' to unary type constructors. +substSym1 :: + (SubstSym1 f, SubstSym a, LinkedRep cb sb, IsSymbolKind knd) => + TypedSymbol knd cb -> + sb -> + f a -> + f a +substSym1 = liftSubstSym substSym + +-- | Lifting of 'SubstSym' to binary type constructors. +class + (forall a. (SubstSym a) => SubstSym1 (f a)) => + SubstSym2 f + where + -- | Lift a symbol substitution function to binary type constructors. + liftSubstSym2 :: + (LinkedRep cb sb, IsSymbolKind knd) => + (TypedSymbol knd cb -> sb -> a -> a) -> + (TypedSymbol knd cb -> sb -> b -> b) -> + TypedSymbol knd cb -> + sb -> + f a b -> + f a b + +-- | Lifting the standard 'substSym' to binary type constructors. +substSym2 :: + (SubstSym2 f, SubstSym a, SubstSym b, LinkedRep cb sb, IsSymbolKind knd) => + TypedSymbol knd cb -> + sb -> + f a b -> + f a b +substSym2 = liftSubstSym2 substSym substSym + +-- Derivations + +-- | The arguments to the generic 'substSym' function. +data family SubstSymArgs arity (knd :: SymbolKind) a cb sb :: Type + +data instance SubstSymArgs Arity0 _ _ _ _ = SubstSymArgs0 + +newtype instance SubstSymArgs Arity1 knd a cb sb + = SubstSymArgs1 (TypedSymbol knd cb -> sb -> a -> a) + +-- | The class of types where we can generically substitute the symbols in a +-- value. +class GSubstSym arity f where + gsubstSym :: + (LinkedRep cb sb, IsSymbolKind knd) => + SubstSymArgs arity knd a cb sb -> + TypedSymbol knd cb -> + sb -> + f a -> + f a + +instance GSubstSym arity V1 where + gsubstSym _ _ _ = id + {-# INLINE gsubstSym #-} + +instance GSubstSym arity U1 where + gsubstSym _ _ _ = id + {-# INLINE gsubstSym #-} + +instance (SubstSym a) => GSubstSym arity (K1 i a) where + gsubstSym _ sym val (K1 v) = K1 $ substSym sym val v + {-# INLINE gsubstSym #-} + +instance (GSubstSym arity a) => GSubstSym arity (M1 i c a) where + gsubstSym args sym val (M1 v) = M1 $ gsubstSym args sym val v + {-# INLINE gsubstSym #-} + +instance (GSubstSym arity a, GSubstSym arity b) => GSubstSym arity (a :*: b) where + gsubstSym args sym val (a :*: b) = + gsubstSym args sym val a :*: gsubstSym args sym val b + {-# INLINE gsubstSym #-} + +instance (GSubstSym arity a, GSubstSym arity b) => GSubstSym arity (a :+: b) where + gsubstSym args sym val (L1 l) = L1 $ gsubstSym args sym val l + gsubstSym args sym val (R1 r) = R1 $ gsubstSym args sym val r + {-# INLINE gsubstSym #-} + +instance (SubstSym1 a) => GSubstSym Arity1 (Rec1 a) where + gsubstSym (SubstSymArgs1 f) sym val (Rec1 v) = + Rec1 $ liftSubstSym f sym val v + {-# INLINE gsubstSym #-} + +instance GSubstSym Arity1 Par1 where + gsubstSym (SubstSymArgs1 f) sym val (Par1 v) = Par1 $ f sym val v + {-# INLINE gsubstSym #-} + +instance + (SubstSym1 f, GSubstSym Arity1 g) => + GSubstSym Arity1 (f :.: g) + where + gsubstSym targs sym val (Comp1 x) = + Comp1 $ liftSubstSym (gsubstSym targs) sym val x + {-# INLINE gsubstSym #-} + +-- | Generic 'substSym' function. +genericSubstSym :: + (Generic a, GSubstSym Arity0 (Rep a), LinkedRep cb sb, IsSymbolKind knd) => + TypedSymbol knd cb -> + sb -> + a -> + a +genericSubstSym sym val = + to . gsubstSym SubstSymArgs0 sym val . from +{-# INLINE genericSubstSym #-} + +-- | Generic 'liftSubstSym' function. +genericLiftSubstSym :: + (Generic1 f, GSubstSym Arity1 (Rep1 f), LinkedRep cb sb, IsSymbolKind knd) => + (TypedSymbol knd cb -> sb -> a -> a) -> + TypedSymbol knd cb -> + sb -> + f a -> + f a +genericLiftSubstSym f sym val = + to1 . gsubstSym (SubstSymArgs1 f) sym val . from1 +{-# INLINE genericLiftSubstSym #-} + +instance + (Generic a, GSubstSym Arity0 (Rep a)) => + SubstSym (Default a) + where + substSym sym val = Default . genericSubstSym sym val . unDefault + {-# INLINE substSym #-} + +instance + (Generic1 f, GSubstSym Arity1 (Rep1 f), SubstSym a) => + SubstSym (Default1 f a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance + (Generic1 f, GSubstSym Arity1 (Rep1 f)) => + SubstSym1 (Default1 f) + where + liftSubstSym f sym val = + Default1 . genericLiftSubstSym f sym val . unDefault1 + {-# INLINE liftSubstSym #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymEq.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymEq.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( -- * Symbolic equality + SymEq (..), + SymEq1 (..), + symEq1, + SymEq2 (..), + symEq2, + pairwiseSymDistinct, + + -- * More 'Eq' helper + distinct, + + -- * Generic 'SymEq' + SymEqArgs (..), + GSymEq (..), + genericSymEq, + genericLiftSymEq, + ) +where + +import Data.Kind (Type) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- | Check if all elements in a list are distinct. +-- +-- Note that empty or singleton lists are always distinct. +-- +-- >>> distinct [] +-- True +-- >>> distinct [1] +-- True +-- >>> distinct [1, 2, 3] +-- True +-- >>> distinct [1, 2, 2] +-- False +distinct :: (Eq a) => [a] -> Bool +distinct [] = True +distinct [_] = True +distinct (x : xs) = go x xs && distinct xs + where + go _ [] = True + go x' (y : ys) = x' /= y .&& go x' ys + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a .== b +-- false +-- >>> a ./= b +-- true +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a .== b +-- (= a b) +-- >>> a ./= b +-- (distinct a b) +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SymEq via (Default X) +class SymEq a where + (.==) :: a -> a -> SymBool + a .== b = symNot $ a ./= b + {-# INLINE (.==) #-} + infix 4 .== + + (./=) :: a -> a -> SymBool + a ./= b = symNot $ a .== b + {-# INLINE (./=) #-} + infix 4 ./= + + -- | Check if all elements in a list are distinct, under the symbolic equality + -- semantics. + symDistinct :: [a] -> SymBool + symDistinct = pairwiseSymDistinct + + {-# MINIMAL (.==) | (./=) #-} + +-- | Default pairwise symbolic distinct implementation. +pairwiseSymDistinct :: (SymEq a) => [a] -> SymBool +pairwiseSymDistinct [] = con True +pairwiseSymDistinct [_] = con True +pairwiseSymDistinct (x : xs) = go x xs .&& pairwiseSymDistinct xs + where + go _ [] = con True + go x' (y : ys) = x' ./= y .&& go x' ys + +-- | Lifting of the 'SymEq' class to unary type constructors. +-- +-- Any instance should be subject to the following law that canonicity is +-- preserved: +-- +-- @liftSymEq (.==)@ should be equivalent to @(.==)@, under the symbolic +-- semantics. +-- +-- This class therefore represents the generalization of 'SymEq' by decomposing +-- its main method into a canonical lifting on a canonical inner method, so that +-- the lifting can be reused for other arguments than the canonical one. +class (forall a. (SymEq a) => SymEq (f a)) => SymEq1 f where + -- | Lift a symbolic equality test through the type constructor. + -- + -- The function will usually be applied to an symbolic equality function, but + -- the more general type ensures that the implementation uses it to compare + -- elements of the first container with elements of the second. + liftSymEq :: (a -> b -> SymBool) -> f a -> f b -> SymBool + +-- | Lift the standard @('.==')@ function through the type constructor. +symEq1 :: (SymEq a, SymEq1 f) => f a -> f a -> SymBool +symEq1 = liftSymEq (.==) + +-- | Lifting of the 'SymEq' class to binary type constructors. +class (forall a. (SymEq a) => SymEq1 (f a)) => SymEq2 f where + -- | Lift symbolic equality tests through the type constructor. + -- + -- The function will usually be applied to an symbolic equality function, but + -- the more general type ensures that the implementation uses it to compare + -- elements of the first container with elements of the second. + liftSymEq2 :: + (a -> b -> SymBool) -> + (c -> d -> SymBool) -> + f a c -> + f b d -> + SymBool + +-- | Lift the standard @('.==')@ function through the type constructor. +symEq2 :: (SymEq a, SymEq b, SymEq2 f) => f a b -> f a b -> SymBool +symEq2 = liftSymEq2 (.==) (.==) + +-- Derivations + +-- | The arguments to the generic equality function. +data family SymEqArgs arity a b :: Type + +data instance SymEqArgs Arity0 _ _ = SymEqArgs0 + +newtype instance SymEqArgs Arity1 a b = SymEqArgs1 (a -> b -> SymBool) + +-- | The class of types that can be generically compared for symbolic equality. +class GSymEq arity f where + gsymEq :: SymEqArgs arity a b -> f a -> f b -> SymBool + +instance GSymEq arity V1 where + gsymEq _ _ _ = con True + {-# INLINE gsymEq #-} + +instance GSymEq arity U1 where + gsymEq _ _ _ = con True + {-# INLINE gsymEq #-} + +instance (GSymEq arity a, GSymEq arity b) => GSymEq arity (a :*: b) where + gsymEq args (a1 :*: b1) (a2 :*: b2) = gsymEq args a1 a2 .&& gsymEq args b1 b2 + {-# INLINE gsymEq #-} + +instance (GSymEq arity a, GSymEq arity b) => GSymEq arity (a :+: b) where + gsymEq args (L1 a1) (L1 a2) = gsymEq args a1 a2 + gsymEq args (R1 b1) (R1 b2) = gsymEq args b1 b2 + gsymEq _ _ _ = con False + {-# INLINE gsymEq #-} + +instance (GSymEq arity a) => GSymEq arity (M1 i c a) where + gsymEq args (M1 a1) (M1 a2) = gsymEq args a1 a2 + {-# INLINE gsymEq #-} + +instance (SymEq a) => GSymEq arity (K1 i a) where + gsymEq _ (K1 a) (K1 b) = a .== b + {-# INLINE gsymEq #-} + +instance GSymEq Arity1 Par1 where + gsymEq (SymEqArgs1 e) (Par1 a) (Par1 b) = e a b + {-# INLINE gsymEq #-} + +instance (SymEq1 f) => GSymEq Arity1 (Rec1 f) where + gsymEq (SymEqArgs1 e) (Rec1 a) (Rec1 b) = liftSymEq e a b + {-# INLINE gsymEq #-} + +instance (SymEq1 f, GSymEq Arity1 g) => GSymEq Arity1 (f :.: g) where + gsymEq targs (Comp1 a) (Comp1 b) = liftSymEq (gsymEq targs) a b + {-# INLINE gsymEq #-} + +instance (Generic a, GSymEq Arity0 (Rep a)) => SymEq (Default a) where + Default l .== Default r = genericSymEq l r + {-# INLINE (.==) #-} + +-- | Generic @('.==')@ function. +genericSymEq :: (Generic a, GSymEq Arity0 (Rep a)) => a -> a -> SymBool +genericSymEq l r = gsymEq SymEqArgs0 (from l) (from r) +{-# INLINE genericSymEq #-} + +instance (Generic1 f, GSymEq Arity1 (Rep1 f), SymEq a) => SymEq (Default1 f a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (Generic1 f, GSymEq Arity1 (Rep1 f)) => SymEq1 (Default1 f) where + liftSymEq f (Default1 l) (Default1 r) = genericLiftSymEq f l r + {-# INLINE liftSymEq #-} + +-- | Generic 'liftSymEq' function. +genericLiftSymEq :: + (Generic1 f, GSymEq Arity1 (Rep1 f)) => + (a -> b -> SymBool) -> + f a -> + f b -> + SymBool +genericLiftSymEq f l r = gsymEq (SymEqArgs1 f) (from1 l) (from1 r) +{-# INLINE genericLiftSymEq #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymOrd.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymOrd.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + ( -- * Symbolic total order relation + SymOrd (..), + SymOrd1 (..), + symCompare1, + SymOrd2 (..), + symCompare2, + + -- * Min and max + symMax, + symMin, + mrgMax, + mrgMin, + + -- * Generic 'SymOrd' + SymOrdArgs (..), + GSymOrd (..), + genericSymCompare, + genericLiftSymCompare, + ) +where + +import Data.Kind (Type) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp, symIte) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot), + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SymBranching, + mrgIf, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( GSymEq, + SymEq ((.==)), + SymEq1, + SymEq2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( mrgSingle, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' +-- value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a .< b +-- true +-- >>> a .> b +-- false +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a .< b +-- (< a b) +-- >>> a .<= b +-- (<= a b) +-- >>> a .> b +-- (< b a) +-- >>> a .>= b +-- (<= b a) +-- +-- For `symCompare`, `Ordering` is not a solvable type, and the result would +-- be wrapped in a union-like monad. See +-- `Grisette.Core.Control.Monad.Union` and `Grisette.Core.PlainUnion` for more +-- information. +-- +-- >>> a `symCompare` b :: Union Ordering +-- {If (< a b) LT (If (= a b) EQ GT)} +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SymOrd via (Default X) +class (SymEq a) => SymOrd a where + (.<) :: a -> a -> SymBool + infix 4 .< + (.<=) :: a -> a -> SymBool + infix 4 .<= + (.>) :: a -> a -> SymBool + infix 4 .> + (.>=) :: a -> a -> SymBool + infix 4 .>= + x .< y = + simpleMerge $ + symCompare x y >>= \case + LT -> con True + EQ -> con False + GT -> con False + {-# INLINE (.<) #-} + x .<= y = symNot (x .> y) + {-# INLINE (.<=) #-} + x .> y = y .< x + {-# INLINE (.>) #-} + x .>= y = y .<= x + {-# INLINE (.>=) #-} + symCompare :: a -> a -> Union Ordering + symCompare l r = + mrgIf + (l .< r) + (mrgSingle LT) + (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) + {-# INLINE symCompare #-} + {-# MINIMAL (.<) | symCompare #-} + +-- | Lifting of the 'SymOrd' class to unary type constructors. +-- +-- Any instance should be subject to the following law that canonicity is +-- preserved: +-- +-- @liftSymCompare symCompare@ should be equivalent to @symCompare@, under the +-- symbolic semantics. +-- +-- This class therefore represents the generalization of 'SymOrd' by decomposing +-- its main method into a canonical lifting on a canonical inner method, so that +-- the lifting can be reused for other arguments than the canonical one. +class (SymEq1 f, forall a. (SymOrd a) => SymOrd (f a)) => SymOrd1 f where + -- | Lift a 'symCompare' function through the type constructor. + -- + -- The function will usually be applied to an symbolic comparison function, + -- but the more general type ensures that the implementation uses it to + -- compare elements of the first container with elements of the second. + liftSymCompare :: (a -> b -> Union Ordering) -> f a -> f b -> Union Ordering + +-- | Lift the standard 'symCompare' function to binary type constructors. +symCompare1 :: (SymOrd1 f, SymOrd a) => f a -> f a -> Union Ordering +symCompare1 = liftSymCompare symCompare +{-# INLINE symCompare1 #-} + +-- | Lifting of the 'SymOrd' class to binary type constructors. +class (SymEq2 f, forall a. (SymOrd a) => SymOrd1 (f a)) => SymOrd2 f where + -- | Lift a 'symCompare' function through the type constructor. + -- + -- The function will usually be applied to an symbolic comparison function, + -- but the more general type ensures that the implementation uses it to + -- compare elements of the first container with elements of the second. + liftSymCompare2 :: + (a -> b -> Union Ordering) -> + (c -> d -> Union Ordering) -> + f a c -> + f b d -> + Union Ordering + +-- | Lift the standard 'symCompare' function through the type constructors. +symCompare2 :: (SymOrd2 f, SymOrd a, SymOrd b) => f a b -> f a b -> Union Ordering +symCompare2 = liftSymCompare2 symCompare symCompare +{-# INLINE symCompare2 #-} + +-- | Symbolic maximum. +symMax :: (SymOrd a, ITEOp a) => a -> a -> a +symMax x y = symIte (x .>= y) x y +{-# INLINE symMax #-} + +-- | Symbolic minimum. +symMin :: (SymOrd a, ITEOp a) => a -> a -> a +symMin x y = symIte (x .>= y) y x +{-# INLINE symMin #-} + +-- | Symbolic maximum, with a union-like monad. +mrgMax :: + (SymOrd a, Mergeable a, SymBranching m, Applicative m) => + a -> + a -> + m a +mrgMax x y = mrgIf (x .>= y) (pure x) (pure y) +{-# INLINE mrgMax #-} + +-- | Symbolic minimum, with a union-like monad. +mrgMin :: + (SymOrd a, Mergeable a, SymBranching m, Applicative m) => + a -> + a -> + m a +mrgMin x y = mrgIf (x .>= y) (pure y) (pure x) +{-# INLINE mrgMin #-} + +-- Derivations + +-- | The arguments to the generic comparison function. +data family SymOrdArgs arity a b :: Type + +data instance SymOrdArgs Arity0 _ _ = SymOrdArgs0 + +newtype instance SymOrdArgs Arity1 a b + = SymOrdArgs1 (a -> b -> Union Ordering) + +-- | The class of types that can be generically symbolically compared. +class GSymOrd arity f where + gsymCompare :: SymOrdArgs arity a b -> f a -> f b -> Union Ordering + +instance GSymOrd arity V1 where + gsymCompare _ _ _ = mrgSingle EQ + {-# INLINE gsymCompare #-} + +instance GSymOrd arity U1 where + gsymCompare _ _ _ = mrgSingle EQ + {-# INLINE gsymCompare #-} + +instance + (GSymOrd arity a, GSymOrd arity b) => + GSymOrd arity (a :*: b) + where + gsymCompare args (a1 :*: b1) (a2 :*: b2) = do + l <- gsymCompare args a1 a2 + case l of + EQ -> gsymCompare args b1 b2 + _ -> mrgSingle l + {-# INLINE gsymCompare #-} + +instance + (GSymOrd arity a, GSymOrd arity b) => + GSymOrd arity (a :+: b) + where + gsymCompare args (L1 a) (L1 b) = gsymCompare args a b + gsymCompare _ (L1 _) (R1 _) = mrgSingle LT + gsymCompare args (R1 a) (R1 b) = gsymCompare args a b + gsymCompare _ (R1 _) (L1 _) = mrgSingle GT + {-# INLINE gsymCompare #-} + +instance (GSymOrd arity a) => GSymOrd arity (M1 i c a) where + gsymCompare args (M1 a) (M1 b) = gsymCompare args a b + {-# INLINE gsymCompare #-} + +instance (SymOrd a) => GSymOrd arity (K1 i a) where + gsymCompare _ (K1 a) (K1 b) = a `symCompare` b + {-# INLINE gsymCompare #-} + +instance GSymOrd Arity1 Par1 where + gsymCompare (SymOrdArgs1 c) (Par1 a) (Par1 b) = c a b + {-# INLINE gsymCompare #-} + +instance (SymOrd1 f) => GSymOrd Arity1 (Rec1 f) where + gsymCompare (SymOrdArgs1 c) (Rec1 a) (Rec1 b) = liftSymCompare c a b + {-# INLINE gsymCompare #-} + +instance (SymOrd1 f, GSymOrd Arity1 g) => GSymOrd Arity1 (f :.: g) where + gsymCompare targs (Comp1 a) (Comp1 b) = liftSymCompare (gsymCompare targs) a b + {-# INLINE gsymCompare #-} + +instance + (Generic a, GSymOrd Arity0 (Rep a), GSymEq Arity0 (Rep a)) => + SymOrd (Default a) + where + symCompare (Default l) (Default r) = genericSymCompare l r + {-# INLINE symCompare #-} + +-- | Generic 'symCompare' function. +genericSymCompare :: (Generic a, GSymOrd Arity0 (Rep a)) => a -> a -> Union Ordering +genericSymCompare l r = gsymCompare SymOrdArgs0 (from l) (from r) +{-# INLINE genericSymCompare #-} + +instance + (Generic1 f, GSymOrd Arity1 (Rep1 f), GSymEq Arity1 (Rep1 f), SymOrd a) => + SymOrd (Default1 f a) + where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance + (Generic1 f, GSymOrd Arity1 (Rep1 f), GSymEq Arity1 (Rep1 f)) => + SymOrd1 (Default1 f) + where + liftSymCompare c (Default1 l) (Default1 r) = genericLiftSymCompare c l r + {-# INLINE liftSymCompare #-} + +-- | Generic 'liftSymCompare' function. +genericLiftSymCompare :: + (Generic1 f, GSymOrd Arity1 (Rep1 f)) => + (a -> b -> Union Ordering) -> + f a -> + f b -> + Union Ordering +genericLiftSymCompare c l r = gsymCompare (SymOrdArgs1 c) (from1 l) (from1 r) +{-# INLINE genericLiftSymCompare #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToCon.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToCon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToCon.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon + ( -- * Converting to concrete values + ToCon (..), + ToCon1 (..), + toCon1, + ToCon2 (..), + toCon2, + + -- * Generic 'ToCon' + ToConArgs (..), + GToCon (..), + genericToCon, + genericLiftToCon, + ) +where + +import Data.Kind (Type) +import GHC.Generics + ( Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1 (U1), + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving (Default (Default), Default1 (Default1)) +import Generics.Deriving.Instances () +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (conView)) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Convert a symbolic value to concrete value if possible. +class ToCon a b where + -- | Convert a symbolic value to concrete value if possible. + -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'. + -- + -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer + -- Nothing + -- + -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer + -- Just 1 + -- + -- 'toCon' works on complex types too. + -- + -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer] + -- Just [1,2] + -- + -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer] + -- Nothing + toCon :: a -> Maybe b + +instance {-# INCOHERENT #-} ToCon v v where + toCon = Just + +-- | Lifting of 'ToCon' to unary type constructors. +class (forall a b. (ToCon a b) => ToCon (f1 a) (f2 b)) => ToCon1 f1 f2 where + -- | Lift a conversion to concrete function to unary type constructors. + liftToCon :: (a -> Maybe b) -> f1 a -> Maybe (f2 b) + +-- | Lift the standard 'toCon' to unary type constructors. +toCon1 :: (ToCon1 f1 f2, ToCon a b) => f1 a -> Maybe (f2 b) +toCon1 = liftToCon toCon +{-# INLINE toCon1 #-} + +-- | Lifting of 'ToCon' to binary type constructors. +class (forall a b. (ToCon a b) => ToCon1 (f1 a) (f2 b)) => ToCon2 f1 f2 where + -- | Lift conversion to concrete functions to binary type constructors. + liftToCon2 :: (a -> Maybe b) -> (c -> Maybe d) -> f1 a c -> Maybe (f2 b d) + +-- | Lift the standard 'toCon' to binary type constructors. +toCon2 :: (ToCon2 f1 f2, ToCon a b, ToCon c d) => f1 a c -> Maybe (f2 b d) +toCon2 = liftToCon2 toCon toCon +{-# INLINE toCon2 #-} + +-- Derivations + +-- | The arguments to the generic 'toCon' function. +data family ToConArgs arity a b :: Type + +data instance ToConArgs Arity0 _ _ = ToConArgs0 + +newtype instance ToConArgs Arity1 a b + = ToConArgs1 (a -> Maybe b) + +-- | The class of types that can be generically converted to concrete values. +class GToCon arity f1 f2 where + gtoCon :: ToConArgs arity a b -> f1 a -> Maybe (f2 b) + +instance GToCon arity V1 V1 where + gtoCon _ _ = error "Impossible" + {-# INLINE gtoCon #-} + +instance GToCon arity U1 U1 where + gtoCon _ _ = Just U1 + {-# INLINE gtoCon #-} + +instance + (GToCon arity a b, GToCon arity c d) => + GToCon arity (a :*: c) (b :*: d) + where + gtoCon args (a :*: c) = do + a' <- gtoCon args a + c' <- gtoCon args c + return $ a' :*: c' + {-# INLINE gtoCon #-} + +instance + (GToCon arity a b, GToCon arity c d) => + GToCon arity (a :+: c) (b :+: d) + where + gtoCon args (L1 a) = L1 <$> gtoCon args a + gtoCon args (R1 a) = R1 <$> gtoCon args a + {-# INLINE gtoCon #-} + +instance (GToCon arity a b) => GToCon arity (M1 i c1 a) (M1 i c2 b) where + gtoCon args (M1 a) = M1 <$> gtoCon args a + {-# INLINE gtoCon #-} + +instance (ToCon a b) => GToCon arity (K1 i a) (K1 i b) where + gtoCon _ (K1 a) = K1 <$> toCon a + {-# INLINE gtoCon #-} + +instance GToCon Arity1 Par1 Par1 where + gtoCon (ToConArgs1 f) (Par1 a) = Par1 <$> f a + {-# INLINE gtoCon #-} + +instance (ToCon1 f1 f2) => GToCon Arity1 (Rec1 f1) (Rec1 f2) where + gtoCon (ToConArgs1 f) (Rec1 a) = Rec1 <$> liftToCon f a + {-# INLINE gtoCon #-} + +instance + (ToCon1 f1 f2, GToCon Arity1 g1 g2) => + GToCon Arity1 (f1 :.: g1) (f2 :.: g2) + where + gtoCon targs (Comp1 a) = Comp1 <$> liftToCon (gtoCon targs) a + {-# INLINE gtoCon #-} + +-- | Generic 'toCon' function. +genericToCon :: + (Generic a, Generic b, GToCon Arity0 (Rep a) (Rep b)) => + a -> + Maybe b +genericToCon = fmap to . gtoCon ToConArgs0 . from +{-# INLINE genericToCon #-} + +-- | Generic 'liftToCon' function. +genericLiftToCon :: + (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2)) => + (a -> Maybe b) -> + f1 a -> + Maybe (f2 b) +genericLiftToCon f = fmap to1 . gtoCon (ToConArgs1 f) . from1 +{-# INLINE genericLiftToCon #-} + +instance + (Generic a, Generic b, GToCon Arity0 (Rep a) (Rep b)) => + ToCon a (Default b) + where + toCon = fmap Default . genericToCon + {-# INLINE toCon #-} + +instance + (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2), ToCon a b) => + ToCon (f1 a) (Default1 f2 b) + where + toCon = toCon1 + +instance + (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2)) => + ToCon1 f1 (Default1 f2) + where + liftToCon f = fmap Default1 . genericLiftToCon f + {-# INLINE liftToCon #-} + +instance ToCon SymBool Bool where + toCon = conView diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToSym.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToSym.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym + ( -- * Converting to symbolic values + ToSym (..), + ToSym1 (..), + toSym1, + ToSym2 (..), + toSym2, + + -- * Generic 'ToSym' + ToSymArgs (..), + GToSym (..), + genericToSym, + genericLiftToSym, + ) +where + +import Data.Kind (Type) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1 (U1), + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.SymPrim + +-- | Convert a concrete value to symbolic value. +class ToSym a b where + -- | Convert a concrete value to symbolic value. + -- + -- >>> toSym False :: SymBool + -- false + -- + -- >>> toSym [False, True] :: [SymBool] + -- [false,true] + toSym :: a -> b + +instance {-# INCOHERENT #-} ToSym a a where + toSym = id + {-# INLINE toSym #-} + +-- | Lifting of 'ToSym' to unary type constructors. +class + (forall a b. (ToSym a b) => ToSym (f1 a) (f2 b)) => + ToSym1 f1 f2 + where + -- | Lift a conversion to symbolic function to unary type constructors. + liftToSym :: (a -> b) -> f1 a -> f2 b + +-- | Lift the standard 'toSym' to unary type constructors. +toSym1 :: (ToSym1 f1 f2, ToSym a b) => f1 a -> f2 b +toSym1 = liftToSym toSym +{-# INLINE toSym1 #-} + +-- | Lifting of 'ToSym' to binary type constructors. +class + (forall a b. (ToSym a b) => ToSym1 (f1 a) (f2 b)) => + ToSym2 f1 f2 + where + -- | Lift conversion to symbolic functions to binary type constructors. + liftToSym2 :: (a -> b) -> (c -> d) -> f1 a c -> f2 b d + +-- | Lift the standard 'toSym' to binary type constructors. +toSym2 :: (ToSym2 f1 f2, ToSym a b, ToSym c d) => f1 a c -> f2 b d +toSym2 = liftToSym2 toSym toSym +{-# INLINE toSym2 #-} + +-- Derivations + +-- | The arguments to the generic 'toSym' function. +data family ToSymArgs arity a b :: Type + +data instance ToSymArgs Arity0 _ _ = ToSymArgs0 + +data instance ToSymArgs Arity1 _ _ where + ToSymArgs1 :: (a -> b) -> ToSymArgs Arity1 a b + +-- | The class of types that can be generically converted to symbolic values. +class GToSym arity f1 f2 where + gtoSym :: ToSymArgs arity a b -> f1 a -> f2 b + +instance GToSym arity V1 V1 where + gtoSym _ _ = error "Impossible" + {-# INLINE gtoSym #-} + +instance GToSym arity U1 U1 where + gtoSym _ _ = U1 + {-# INLINE gtoSym #-} + +instance + (GToSym arity a b, GToSym arity c d) => + GToSym arity (a :+: c) (b :+: d) + where + gtoSym args (L1 a) = L1 $ gtoSym args a + gtoSym args (R1 b) = R1 $ gtoSym args b + {-# INLINE gtoSym #-} + +instance + (GToSym arity a b, GToSym arity c d) => + GToSym arity (a :*: c) (b :*: d) + where + gtoSym args (a :*: c) = gtoSym args a :*: gtoSym args c + {-# INLINE gtoSym #-} + +instance (ToSym a b) => GToSym arity (K1 i a) (K1 i b) where + gtoSym _ (K1 a) = K1 $ toSym a + {-# INLINE gtoSym #-} + +instance (GToSym arity f1 f2) => GToSym arity (M1 i c1 f1) (M1 i c2 f2) where + gtoSym args (M1 a) = M1 $ gtoSym args a + {-# INLINE gtoSym #-} + +instance GToSym Arity1 Par1 Par1 where + gtoSym (ToSymArgs1 f) (Par1 a) = Par1 $ f a + {-# INLINE gtoSym #-} + +instance (ToSym1 f1 f2) => GToSym Arity1 (Rec1 f1) (Rec1 f2) where + gtoSym (ToSymArgs1 f) (Rec1 a) = Rec1 $ liftToSym f a + {-# INLINE gtoSym #-} + +instance + (ToSym1 f1 f2, GToSym Arity1 g1 g2) => + GToSym Arity1 (f1 :.: g1) (f2 :.: g2) + where + gtoSym targs@ToSymArgs1 {} (Comp1 a) = Comp1 $ liftToSym (gtoSym targs) a + {-# INLINE gtoSym #-} + +-- | Generic 'toSym' function. +genericToSym :: + (Generic a, Generic b, GToSym Arity0 (Rep a) (Rep b)) => + a -> + b +genericToSym = to . gtoSym ToSymArgs0 . from +{-# INLINE genericToSym #-} + +-- | Generic 'liftToSym' function. +genericLiftToSym :: + (Generic1 f1, Generic1 f2, GToSym Arity1 (Rep1 f1) (Rep1 f2)) => + (a -> b) -> + f1 a -> + f2 b +genericLiftToSym f = to1 . gtoSym (ToSymArgs1 f) . from1 +{-# INLINE genericLiftToSym #-} + +instance + ( Generic a, + Generic b, + GToSym Arity0 (Rep a) (Rep b) + ) => + ToSym a (Default b) + where + toSym = Default . genericToSym + {-# INLINE toSym #-} + +instance + ( Generic1 f1, + Generic1 f2, + GToSym Arity1 (Rep1 f1) (Rep1 f2), + ToSym a b + ) => + ToSym (f1 a) (Default1 f2 b) + where + toSym = toSym1 + +instance + ( Generic1 f1, + Generic1 f2, + GToSym Arity1 (Rep1 f1) (Rep1 f2) + ) => + ToSym1 f1 (Default1 f2) + where + liftToSym f = Default1 . genericLiftToSym f + {-# INLINE liftToSym #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/Class/TryMerge.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/TryMerge.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/Class/TryMerge.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge +-- Copyright : (c) Sirui Lu 2023-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( TryMerge (..), + tryMerge, + MonadTryMerge, + mrgSingle, + mrgSingleWithStrategy, + mrgToSym, + toUnionSym, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + MergingStrategy, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym (ToSym (toSym)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | A class for containers that may or may not be merged. +-- +-- If the container is capable of multi-path execution, then the +-- `tryMergeWithStrategy` function should merge the paths according to the +-- supplied strategy. +-- +-- If the container is not capable of multi-path execution, then the +-- `tryMergeWithStrategy` function should be equivalent to `id`. +-- +-- Note that this will not necessarily do a recursive merge for the elements. +class TryMerge m where + tryMergeWithStrategy :: MergingStrategy a -> m a -> m a + +-- | Try to merge the container with the root strategy. +tryMerge :: (TryMerge m, Mergeable a) => m a -> m a +tryMerge = tryMergeWithStrategy rootStrategy +{-# INLINE tryMerge #-} + +-- | Wrap a value in the applicative functor and capture the 'Mergeable' +-- knowledge. +-- +-- >>> mrgSingleWithStrategy rootStrategy "a" :: Union SymInteger +-- {a} +-- +-- __Note:__ Be careful to call this directly from your code. +-- The supplied merge strategy should be consistent with the type's root merge +-- strategy, or some internal invariants would be broken and the program can +-- crash. +-- +-- This function is to be called when the 'Mergeable' constraint can not be +-- resolved, e.g., the merge strategy for the contained type is given with +-- 'Grisette.Mergeable1'. In other cases, +-- 'Grisette.Lib.Control.Applicative.mrgPure' is usually a better alternative. +mrgSingleWithStrategy :: + (TryMerge m, Applicative m) => + MergingStrategy a -> + a -> + m a +mrgSingleWithStrategy strategy = tryMergeWithStrategy strategy . pure +{-# INLINE mrgSingleWithStrategy #-} + +-- | Wrap a value in the applicative functor and propagate the type's root merge +-- strategy. +-- +-- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@. +-- +-- >>> mrgSingle "a" :: Union SymInteger +-- {a} +mrgSingle :: (TryMerge m, Applicative m, Mergeable a) => a -> m a +mrgSingle = mrgSingleWithStrategy rootStrategy +{-# INLINE mrgSingle #-} + +-- | Alias for a monad type that has 'TryMerge'. +type MonadTryMerge f = (TryMerge f, Monad f) + +-- | Convert a value to symbolic value and wrap it with a mergeable container. +-- +-- This is a synonym for 'toUnionSym'. +mrgToSym :: + (ToSym a b, Mergeable b, TryMerge m, Applicative m) => + a -> + m b +mrgToSym = toUnionSym +{-# INLINE mrgToSym #-} + +-- | Convert a value to symbolic value and wrap it with a mergeable container. +-- +-- This is a synonym for 'toUnionSym'. +toUnionSym :: + (ToSym a b, Mergeable b, TryMerge m, Applicative m) => + a -> + m b +toUnionSym = tryMerge . pure . toSym +{-# INLINE toUnionSym #-} diff --git a/src/Grisette/Internal/Internal/Decl/Core/Data/UnionBase.hs b/src/Grisette/Internal/Internal/Decl/Core/Data/UnionBase.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Core/Data/UnionBase.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Core.Data.UnionBase +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Core.Data.UnionBase + ( -- * The union data structure. + + -- | Please consider using 'Grisette.Core.Union' instead. + UnionBase (..), + ifWithLeftMost, + ifWithStrategy, + fullReconstruct, + ) +where + +import Control.Monad (ap) +import GHC.Generics (Generic, Generic1) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (ifView, singleView), + ) +import Grisette.Internal.Core.Data.Class.Solvable (pattern Con) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Language.Haskell.TH.Syntax (Lift) + +-- | The base union implementation, which is an if-then-else tree structure. +data UnionBase a where + -- | A single value + UnionSingle :: a -> UnionBase a + -- | A if value + UnionIf :: + -- | Cached leftmost value + a -> + -- | Is merged invariant already maintained? + !Bool -> + -- | If condition + !SymBool -> + -- | True branch + UnionBase a -> + -- | False branch + UnionBase a -> + UnionBase a + deriving (Generic, Eq, Lift, Generic1) + deriving (Functor) + +instance Applicative UnionBase where + pure = UnionSingle + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad UnionBase where + return = pure + {-# INLINE return #-} + UnionSingle a >>= f = f a + UnionIf _ _ c t f >>= f' = ifWithLeftMost False c (t >>= f') (f >>= f') + {-# INLINE (>>=) #-} + +instance TryMerge UnionBase where + tryMergeWithStrategy = fullReconstruct + {-# INLINE tryMergeWithStrategy #-} + +-- | Fully reconstruct a 'Grisette.Core.Union' to maintain the merged invariant. +fullReconstruct :: MergingStrategy a -> UnionBase a -> UnionBase a +fullReconstruct strategy (UnionIf _ False cond t f) = + ifWithStrategyInv + strategy + cond + (fullReconstruct strategy t) + (fullReconstruct strategy f) +fullReconstruct _ u = u +{-# INLINE fullReconstruct #-} + +leftMost :: UnionBase a -> a +leftMost (UnionSingle a) = a +leftMost (UnionIf a _ _ _ _) = a +{-# INLINE leftMost #-} + +-- | Build 'UnionIf' with leftmost cache correctly maintained. +-- +-- Usually you should never directly try to build a 'UnionIf' with its +-- constructor. +ifWithLeftMost :: Bool -> SymBool -> UnionBase a -> UnionBase a -> UnionBase a +ifWithLeftMost _ (Con c) t f + | c = t + | otherwise = f +ifWithLeftMost inv cond t f = UnionIf (leftMost t) inv cond t f +{-# INLINE ifWithLeftMost #-} + +-- | Use a specific strategy to build a 'UnionIf' value. +-- +-- The merged invariant will be maintained in the result. +ifWithStrategy :: + MergingStrategy a -> + SymBool -> + UnionBase a -> + UnionBase a -> + UnionBase a +ifWithStrategy strategy cond t@(UnionIf _ False _ _ _) f = + ifWithStrategy strategy cond (fullReconstruct strategy t) f +ifWithStrategy strategy cond t f@(UnionIf _ False _ _ _) = + ifWithStrategy strategy cond t (fullReconstruct strategy f) +ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f +{-# INLINE ifWithStrategy #-} + +ifWithStrategyInv :: + MergingStrategy a -> + SymBool -> + UnionBase a -> + UnionBase a -> + UnionBase a +ifWithStrategyInv _ (Con v) t f + | v = t + | otherwise = f +ifWithStrategyInv strategy cond (UnionIf _ True condTrue tt _) f + | 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 #-} + +instance (Mergeable a) => Mergeable (UnionBase a) where + rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 UnionBase where + liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms + {-# INLINE liftRootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (UnionBase a) where + mrgIte = mrgIf + +instance SimpleMergeable1 UnionBase where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + +instance SymBranching UnionBase where + mrgIfWithStrategy = ifWithStrategy + {-# INLINE mrgIfWithStrategy #-} + + mrgIfPropagatedStrategy = ifWithLeftMost False + {-# INLINE mrgIfPropagatedStrategy #-} + +instance PlainUnion UnionBase where + singleView (UnionSingle a) = Just a + singleView _ = Nothing + {-# INLINE singleView #-} + ifView (UnionIf _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) + ifView _ = Nothing + {-# INLINE ifView #-} diff --git a/src/Grisette/Internal/Internal/Decl/SymPrim/AllSyms.hs b/src/Grisette/Internal/Internal/Decl/SymPrim/AllSyms.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/SymPrim/AllSyms.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.SymPrim.AllSyms +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( -- * Get all symbolic primitive values in a value + SomeSym (..), + AllSyms (..), + AllSyms1 (..), + allSymsS1, + AllSyms2 (..), + allSymsS2, + allSymsSize, + symSize, + symsSize, + + -- * Generic 'AllSyms' + AllSymsArgs (..), + GAllSyms (..), + genericAllSymsS, + genericLiftAllSymsS, + ) +where + +import Data.Kind (Type) +import GHC.Generics + ( Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving + ( Default (unDefault), + Default1 (unDefault1), + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (SomeTerm), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (underlyingTerm), + pformatTerm, + ) +import Grisette.Internal.SymPrim.Prim.TermUtils + ( someTermsSize, + termSize, + termsSize, + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Some symbolic value with 'LinkedRep' constraint. +data SomeSym where + SomeSym :: (LinkedRep con sym) => sym -> SomeSym + +instance Show SomeSym where + show (SomeSym s) = pformatTerm $ underlyingTerm s + +-- | Extract all symbolic primitive values that are represented as SMT terms. +-- +-- >>> allSyms (["a" + 1 :: SymInteger, -"b"], "c" :: SymBool) +-- [(+ 1 a),(- b),c] +-- +-- This is usually used for getting a statistical summary of the size of +-- a symbolic value with 'allSymsSize'. +-- +-- __Note:__ This type class can be derived for algebraic data types. You may +-- need the @DerivingVia@ and @DerivingStrategies@ extenstions. +-- +-- > data X = ... deriving Generic deriving AllSyms via (Default X) +class AllSyms a where + -- | Convert a value to a list of symbolic primitive values. It should + -- prepend to an existing list of symbolic primitive values. + allSymsS :: a -> [SomeSym] -> [SomeSym] + allSymsS a l = allSyms a ++ l + + -- | Specialized 'allSymsS' that prepends to an empty list. + allSyms :: a -> [SomeSym] + allSyms a = allSymsS a [] + + {-# MINIMAL allSymsS | allSyms #-} + +-- | Get the sum of the sizes of a list of symbolic terms. +-- Duplicate sub-terms are counted for only once. +-- +-- >>> symsSize [1, "a" :: SymInteger, "a" + 1 :: SymInteger] +-- 3 +symsSize :: forall con sym. (LinkedRep con sym) => [sym] -> Int +symsSize = termsSize . fmap (underlyingTerm @con) +{-# INLINE symsSize #-} + +-- | Get the size of a symbolic term. +-- Duplicate sub-terms are counted for only once. +-- +-- >>> symSize (1 :: SymInteger) +-- 1 +-- >>> symSize ("a" :: SymInteger) +-- 1 +-- >>> symSize ("a" + 1 :: SymInteger) +-- 3 +-- >>> symSize (("a" + 1) * ("a" + 1) :: SymInteger) +-- 4 +symSize :: forall con sym. (LinkedRep con sym) => sym -> Int +symSize = termSize . underlyingTerm @con +{-# INLINE symSize #-} + +someUnderlyingTerm :: SomeSym -> SomeTerm +someUnderlyingTerm (SomeSym s) = SomeTerm $ underlyingTerm s + +someSymsSize :: [SomeSym] -> Int +someSymsSize = someTermsSize . fmap someUnderlyingTerm +{-# INLINE someSymsSize #-} + +-- | Get the total size of symbolic terms in a value. +-- Duplicate sub-terms are counted for only once. +-- +-- >>> allSymsSize ("a" :: SymInteger, "a" + "b" :: SymInteger, ("a" + "b") * "c" :: SymInteger) +-- 5 +-- +-- The 5 terms are @a@, @b@, @(+ a b)@, @c@, and @(* (+ a b) c)@. +allSymsSize :: (AllSyms a) => a -> Int +allSymsSize = someSymsSize . allSyms + +-- | Lifting of the 'AllSyms' class to unary type constructors. +class (forall a. (AllSyms a) => AllSyms (f a)) => AllSyms1 f where + -- | Lift the 'allSymsS' function to unary type constructors. + liftAllSymsS :: (a -> [SomeSym] -> [SomeSym]) -> f a -> [SomeSym] -> [SomeSym] + +-- | Lift the standard 'allSymsS' function to unary type constructors. +allSymsS1 :: (AllSyms1 f, AllSyms a) => f a -> [SomeSym] -> [SomeSym] +allSymsS1 = liftAllSymsS allSymsS +{-# INLINE allSymsS1 #-} + +-- | Lifting of the 'AllSyms' class to binary type constructors. +class (forall a. (AllSyms a) => AllSyms1 (f a)) => AllSyms2 f where + -- | Lift the 'allSymsS' function to binary type constructors. + liftAllSymsS2 :: + (a -> [SomeSym] -> [SomeSym]) -> + (b -> [SomeSym] -> [SomeSym]) -> + f a b -> + [SomeSym] -> + [SomeSym] + +-- | Lift the standard 'allSymsS' function to binary type constructors. +allSymsS2 :: + (AllSyms2 f, AllSyms a, AllSyms b) => f a b -> [SomeSym] -> [SomeSym] +allSymsS2 = liftAllSymsS2 allSymsS allSymsS +{-# INLINE allSymsS2 #-} + +-- Derivation + +-- | The arguments to the generic 'AllSyms' function. +data family AllSymsArgs arity a :: Type + +data instance AllSymsArgs Arity0 _ = AllSymsArgs0 + +newtype instance AllSymsArgs Arity1 a + = AllSymsArgs1 (a -> [SomeSym] -> [SomeSym]) + +-- | The class of types that can generically extract all symbolic primitives. +class GAllSyms arity f where + gallSymsS :: AllSymsArgs arity a -> f a -> [SomeSym] -> [SomeSym] + +instance GAllSyms arity V1 where + gallSymsS _ _ = id + +instance GAllSyms arity U1 where + gallSymsS _ _ = id + +instance (AllSyms c) => GAllSyms arity (K1 i c) where + gallSymsS _ (K1 x) = allSymsS x + +instance (GAllSyms arity a) => GAllSyms arity (M1 i c a) where + gallSymsS args (M1 x) = gallSymsS args x + +instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :+: b) where + gallSymsS args (L1 l) = gallSymsS args l + gallSymsS args (R1 r) = gallSymsS args r + +instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :*: b) where + gallSymsS args (a :*: b) = gallSymsS args a . gallSymsS args b + +instance GAllSyms Arity1 Par1 where + gallSymsS (AllSymsArgs1 f) (Par1 x) = f x + +instance (AllSyms1 f) => GAllSyms Arity1 (Rec1 f) where + gallSymsS (AllSymsArgs1 f) (Rec1 x) = liftAllSymsS f x + +instance (AllSyms1 f, GAllSyms Arity1 g) => GAllSyms Arity1 (f :.: g) where + gallSymsS targs (Comp1 x) = liftAllSymsS (gallSymsS targs) x + +-- | Generic 'allSymsS' function. +genericAllSymsS :: + (Generic a, GAllSyms Arity0 (Rep a)) => + a -> + [SomeSym] -> + [SomeSym] +genericAllSymsS x = gallSymsS AllSymsArgs0 (from x) +{-# INLINE genericAllSymsS #-} + +-- | Generic 'liftAllSymsS' function. +genericLiftAllSymsS :: + (Generic1 f, GAllSyms Arity1 (Rep1 f)) => + (a -> [SomeSym] -> [SomeSym]) -> + f a -> + [SomeSym] -> + [SomeSym] +genericLiftAllSymsS f x = gallSymsS (AllSymsArgs1 f) (from1 x) +{-# INLINE genericLiftAllSymsS #-} + +instance (Generic a, GAllSyms Arity0 (Rep a)) => AllSyms (Default a) where + allSymsS = genericAllSymsS . unDefault + {-# INLINE allSymsS #-} + +instance + (Generic1 f, GAllSyms Arity1 (Rep1 f), AllSyms a) => + AllSyms (Default1 f a) + where + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} + +instance (Generic1 f, GAllSyms Arity1 (Rep1 f)) => AllSyms1 (Default1 f) where + liftAllSymsS f = genericLiftAllSymsS f . unDefault1 + {-# INLINE liftAllSymsS #-} diff --git a/src/Grisette/Internal/Internal/Decl/Unified/BVFPConversion.hs b/src/Grisette/Internal/Internal/Decl/Unified/BVFPConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/BVFPConversion.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.BVFPConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.BVFPConversion + ( UnifiedBVFPConversion, + UnifiedBVFPConversionImpl, + SafeUnifiedBVFPConversion, + SafeUnifiedBVFPConversionImpl, + AllUnifiedBVFPConversion, + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (+), type (<=)) +import Grisette.Internal.Core.Data.Class.BitCast + ( BitCast, + BitCastCanonical, + BitCastOr, + ) +import Grisette.Internal.Core.Data.Class.IEEEFP + ( IEEEFPConvertible, + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedBV + ( UnifiedBVImpl (GetIntN, GetWordN), + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP + ( UnifiedFPImpl (GetFP, GetFPRoundingMode), + ) +import Grisette.Internal.SymPrim.FP + ( NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) +import Grisette.Internal.Unified.Class.UnifiedSafeBitCast (UnifiedSafeBitCast) +import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) + +-- | Implementation for 'UnifiedBVFPConversion'. +class + ( UnifiedBVImpl mode wordn intn n word int, + UnifiedFPImpl mode fpn eb sb fp fprd, + BitCast word fp, + BitCast int fp, + BitCastOr fp word, + BitCastOr fp int, + BitCastCanonical fp word, + BitCastCanonical fp int, + UnifiedFromIntegral mode word fp, + UnifiedFromIntegral mode int fp, + IEEEFPConvertible int fp fprd, + IEEEFPConvertible word fp fprd + ) => + UnifiedBVFPConversionImpl + (mode :: EvalModeTag) + wordn + intn + fpn + n + eb + sb + word + int + fp + fprd + +-- | Implementation for 'SafeUnifiedBVFPConversion'. +class + ( UnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd, + UnifiedSafeBitCast mode NotRepresentableFPError fp int m, + UnifiedSafeBitCast mode NotRepresentableFPError fp word m, + UnifiedSafeFromFP mode NotRepresentableFPError word fp fprd m + ) => + SafeUnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd m + +-- | Unified constraints for safe conversion from bit-vectors to floating point +-- numbers. +class + ( SafeUnifiedBVFPConversionImpl + mode + (GetWordN mode) + (GetIntN mode) + (GetFP mode) + n + eb + sb + (GetWordN mode n) + (GetIntN mode n) + (GetFP mode eb sb) + (GetFPRoundingMode mode) + m + ) => + SafeUnifiedBVFPConversion mode n eb sb m + +-- | Unified constraints for conversion from bit-vectors to floating point +-- numbers. +class + ( UnifiedBVFPConversionImpl + (mode :: EvalModeTag) + (GetWordN mode) + (GetIntN mode) + (GetFP mode) + n + eb + sb + (GetWordN mode n) + (GetIntN mode n) + (GetFP mode eb sb) + (GetFPRoundingMode mode) + ) => + UnifiedBVFPConversion mode n eb sb + +-- | Evaluation mode with unified conversion from bit-vectors to +-- floating-points. +class + ( forall n eb sb. + (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => + UnifiedBVFPConversion mode n eb sb, + forall n eb sb m. + ( UnifiedBranching mode m, + ValidFP eb sb, + KnownNat n, + 1 <= n, + n ~ (eb + sb), + MonadError NotRepresentableFPError m + ) => + SafeUnifiedBVFPConversion mode n eb sb m + ) => + AllUnifiedBVFPConversion mode diff --git a/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedITEOp.hs b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedITEOp.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedITEOp.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp + ( UnifiedITEOp (..), + ) +where + +import Data.Kind (Constraint) +import Data.Type.Bool (If) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) +import Grisette.Internal.Unified.EvalModeTag (IsConMode) + +-- | A class that provides unified equality comparison. +-- +-- We use this type class to help resolve the constraints for `ITEOp`. +class UnifiedITEOp mode v where + withBaseITEOp :: + ((If (IsConMode mode) (() :: Constraint) (ITEOp v)) => r) -> r diff --git a/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSimpleMergeable.hs b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSimpleMergeable.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (..), + UnifiedSimpleMergeable (..), + UnifiedSimpleMergeable1 (..), + UnifiedSimpleMergeable2 (..), + ) +where + +import Data.Kind (Constraint) +import Data.Type.Bool (If) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SimpleMergeable, + SimpleMergeable1, + SimpleMergeable2, + SymBranching, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( TryMerge, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag, IsConMode) +import Grisette.Internal.Unified.Util (DecideEvalMode) + +-- | A class that provides a unified simple merging. +-- +-- We use this type class to help resolve the constraints for `SimpleMergeable`. +class (Mergeable a) => UnifiedSimpleMergeable mode a where + withBaseSimpleMergeable :: + ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable a)) => r) -> r + +-- | A class that provides lifting of unified simple merging. +-- +-- We use this type class to help resolve the constraints for +-- `SimpleMergeable1`. +class UnifiedSimpleMergeable1 mode f where + withBaseSimpleMergeable1 :: + ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 f)) => r) -> r + +-- | A class that provides lifting of unified simple merging. +-- +-- We use this type class to help resolve the constraints for +-- `SimpleMergeable2`. +class UnifiedSimpleMergeable2 mode f where + withBaseSimpleMergeable2 :: + ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 f)) => r) -> r + +-- | A class that provides a unified branching operation. +-- +-- We use this type class to help resolve the constraints for +-- `SymBranching`. +class + (DecideEvalMode mode, TryMerge m) => + UnifiedBranching (mode :: EvalModeTag) m + where + withBaseBranching :: + ((If (IsConMode mode) (TryMerge m) (SymBranching m)) => r) -> r diff --git a/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymEq.hs b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymEq.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq + ( UnifiedSymEq (..), + UnifiedSymEq1 (..), + UnifiedSymEq2 (..), + ) +where + +import Data.Functor.Classes (Eq1, Eq2) +import Data.Type.Bool (If) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( SymEq, + SymEq1, + SymEq2, + ) +import Grisette.Internal.Unified.EvalModeTag (IsConMode) + +-- | A class that provides unified equality comparison. +-- +-- We use this type class to help resolve the constraints for `Eq` and `SymEq`. +class UnifiedSymEq mode a where + withBaseSymEq :: ((If (IsConMode mode) (Eq a) (SymEq a)) => r) -> r + +-- | A class that provides unified lifting of equality comparison. +-- +-- We use this type class to help resolve the constraints for `Eq1` and +-- `SymEq1`. +class + (forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a)) => + UnifiedSymEq1 mode f + where + withBaseSymEq1 :: ((If (IsConMode mode) (Eq1 f) (SymEq1 f)) => r) -> r + +-- | A class that provides unified lifting of equality comparison. +-- +-- We use this type class to help resolve the constraints for `Eq2` and +-- `SymEq2`. +class + (forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a)) => + UnifiedSymEq2 mode f + where + withBaseSymEq2 :: ((If (IsConMode mode) (Eq2 f) (SymEq2 f)) => r) -> r diff --git a/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymOrd.hs b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymOrd.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd + ( UnifiedSymOrd (..), + UnifiedSymOrd1 (..), + UnifiedSymOrd2 (..), + ) +where + +import Data.Functor.Classes (Ord1, Ord2) +import Data.Type.Bool (If) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + ( SymOrd, + SymOrd1, + SymOrd2, + ) +import Grisette.Internal.Unified.EvalModeTag (IsConMode) + +-- | A class that provides unified comparison. +-- +-- We use this type class to help resolve the constraints for `Ord` and +-- `SymOrd`. +class UnifiedSymOrd mode a where + withBaseSymOrd :: (((If (IsConMode mode) (Ord a) (SymOrd a)) => r)) -> r + +-- | A class that provides unified lifting of comparison. +-- +-- We use this type class to help resolve the constraints for `Ord1` and +-- `SymOrd1`. +class UnifiedSymOrd1 mode f where + withBaseSymOrd1 :: (((If (IsConMode mode) (Ord1 f) (SymOrd1 f)) => r)) -> r + +-- | A class that provides unified lifting of comparison. +-- +-- We use this type class to help resolve the constraints for `Ord2` and +-- `SymOrd2`. +class UnifiedSymOrd2 mode f where + withBaseSymOrd2 :: (((If (IsConMode mode) (Ord2 f) (SymOrd2 f)) => r)) -> r diff --git a/src/Grisette/Internal/Internal/Decl/Unified/EvalMode.hs b/src/Grisette/Internal/Internal/Decl/Unified/EvalMode.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/EvalMode.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.EvalMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.EvalMode + ( EvalModeBase, + EvalModeInteger, + EvalModeBV, + EvalModeFP, + EvalModeAlgReal, + EvalModeAll, + MonadEvalModeAll, + genEvalMode, + ) +where + +import Data.List (nub) +import Data.Maybe (mapMaybe) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.Internal.Decl.Unified.BVFPConversion + ( AllUnifiedBVFPConversion, + ) +import Grisette.Internal.Internal.Decl.Unified.FPFPConversion + ( AllUnifiedFPFPConversion, + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedBV (AllUnifiedBV) +import Grisette.Internal.Internal.Decl.Unified.UnifiedBool + ( UnifiedBool (GetBool), + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP (AllUnifiedFP) +import Grisette.Internal.Unified.BVBVConversion (AllUnifiedBVBVConversion) +import Grisette.Internal.Unified.BaseMonad (BaseMonad) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.Theories + ( TheoryToUnify (UAlgReal, UFP, UFun, UIntN, UInteger, UWordN), + isUFun, + ) +import Grisette.Internal.Unified.UnifiedAlgReal (UnifiedAlgReal) +import Grisette.Internal.Unified.UnifiedData (AllUnifiedData) +import Grisette.Internal.Unified.UnifiedFun + ( genUnifiedFunInstance, + unifiedFunInstanceName, + ) +import Grisette.Internal.Unified.UnifiedInteger (UnifiedInteger) +import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim) +import Grisette.Internal.Unified.Util (DecideEvalMode) +import Language.Haskell.TH + ( DecsQ, + Type (AppT, ArrowT, ConT, StarT, VarT), + appT, + classD, + conT, + instanceD, + kindedTV, + mkName, + newName, + promotedT, + tySynD, + varT, + ) + +-- | Provide the constraint that the mode is a valid evaluation mode, and +-- provides the support for 'GetBool' and 'Grisette.Internal.Unified.GetData'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +class + ( DecideEvalMode mode, + UnifiedBool mode, + UnifiedBasicPrim mode (GetBool mode), + Monad (BaseMonad mode), + TryMerge (BaseMonad mode), + UnifiedBranching mode (BaseMonad mode), + AllUnifiedData mode + ) => + EvalModeBase mode + +-- | Provide the support for 'Grisette.Internal.Unified.GetIntN', +-- 'Grisette.Internal.Unified.GetWordN', 'Grisette.Internal.Unified.GetSomeIntN', and +-- 'Grisette.Internal.Unified.GetSomeWordN'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +class (AllUnifiedBV mode, AllUnifiedBVBVConversion mode) => EvalModeBV mode + +-- | Provide the support for 'Grisette.Internal.Unified.GetInteger'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +type EvalModeInteger = UnifiedInteger + +-- | Provide the support for 'Grisette.Internal.Unified.GetFP' and +-- 'Grisette.Internal.Unified.GetFPRoundingMode'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +class + ( AllUnifiedFP mode, + AllUnifiedFPFPConversion mode, + AllUnifiedBVFPConversion mode + ) => + EvalModeFP mode + +-- | Provide the support for 'Grisette.Internal.Unified.GetAlgReal'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +type EvalModeAlgReal = UnifiedAlgReal + +-- | A constraint that specifies that the mode is valid, and provide all the +-- corresponding constraints for the operaions for the types. +-- +-- Note for users with GHC prior to 9.2.1: the GHC compiler isn't able to +-- resolve the operations for sized bitvectors and data types. In this case, +-- you may need to provide `Grisette.Internal.Unified.UnifiedBV.UnifiedBV`, +-- `Grisette.Internal.Unified.UnifiedBV.SafeUnifiedBV`, +-- `Grisette.Internal.Unified.UnifiedBV.SafeUnifiedSomeBV`, and +-- `Grisette.Internal.Unified.UnifiedData.UnifiedData` constraints manually. +-- +-- For example, the following code is valid for GHC 9.2.1 and later: +-- +-- > fbv :: +-- > forall mode n. +-- > (EvalMode mode, KnownNat n, 1 <= n) => +-- > GetIntN mode n -> +-- > GetIntN mode n -> +-- > GetIntN mode n +-- > fbv l r = +-- > mrgIte @mode +-- > (l .== r) +-- > (l + r) +-- > (symIte @mode (l .< r) l r) +-- +-- But with older GHCs, you need to write: +-- +-- > fbv :: +-- > forall mode n. +-- > (EvalMode mode, KnownNat n, 1 <= n, UnifiedBV mode n) => +-- > GetIntN mode n -> +-- > GetIntN mode n -> +-- > GetIntN mode n +-- > fbv l r = +-- > mrgIte @mode +-- > (l .== r) +-- > (l + r) +-- > (symIte @mode (l .< r) l r) +class + ( EvalModeBase mode, + EvalModeInteger mode, + EvalModeAlgReal mode, + EvalModeBV mode, + EvalModeFP mode + ) => + EvalModeAll mode + +-- | A constraint that specifies that the mode is valid, and provide all the +-- corresponding constraints for the operations for the types. +-- +-- This also provide the branching constraints for the monad, and the safe +-- operations: for example, 'Grisette.Internal.Unified.SafeUnifiedInteger' provides +-- 'Grisette.safeDiv' for the integer type with in @ExceptT ArithException m@. +-- +-- For users with GHC prior to 9.2.1, see notes in 'EvalModeAll'. +type MonadEvalModeAll mode m = + ( EvalModeAll mode, + Monad m, + TryMerge m, + UnifiedBranching mode m + ) + +-- | This template haskell function generates an EvalMode constraint on demand. +-- +-- For example, if in your system, you are only working on bit-vectors and +-- booleans, but not floating points, integers, or real numbers, you can use +-- this function to generate a constraint that only includes the necessary +-- constraints: +-- +-- > genEvalMode "MyEvalMode" [UWordN, UIntN, UBool] +-- > f :: MyEvalMode mode => GetBool mode -> GetWordN mode 8 -> GetWordN mode 8 +-- > f = ... +-- +-- This may help with faster compilation times. +-- +-- Another usage of this custom constraint is to working with uninterpreted +-- functions. The uninterpreted functions aren't available even with +-- 'EvalModeAll', and is only available with the constraint generated by this +-- function. Note that you need to explicitly list all the uninterpreted +-- function types you need in your system. +-- +-- > genEvalMode "MyEvalModeUF" [UFun [UWordN, UIntN], UFun [UBool, UBool, UWordN]] +-- +-- This will give us a constraint that allows us to work with booleans and +-- bit-vectors, and also the uninterpreted functions that +-- +-- * maps an unsigned bit-vector (any bitwidth) to an unsigned integer (any +-- bitwidth), and +-- * maps two booleans to an unsigned bit-vector (any bitwidth). +-- +-- You can then use them in your code like this: +-- +-- > f :: MyEvalModeUF mode => GetFun mode (GetWordN mode 8) (GetIntN mode 8) -> GetIntN mode 8 +-- > f fun = f # 1 +-- +-- The function will also provide the constraint @MonadMyEvalModeUF@, which +-- includes the constraints for the monad and the unified branching, similar to +-- 'MonadEvalModeAll'. +-- +-- For compilers older than GHC 9.2.1, see the notes for 'EvalModeAll'. This +-- function will also generate constraints like @MyEvalModeUFFunUWordNUIntN@, +-- which can be used to resolve the constraints for older compilers. +-- +-- The naming conversion is the concatenation of the three parts: +-- +-- * The base name provided by the user (i.e., @MyEvalModeUF@), +-- * @Fun@, +-- * The concatenation of all the types in the uninterpreted function (i.e., +-- @UWordNUIntN@). +-- +-- The arguments to the type class is as follows: +-- +-- * The first argument is the mode, +-- * The second to the end arguments are the natural number arguments for all +-- the types. Here the second argument is the bitwidth of the unsigned +-- bit-vector argument, and the third argument is the bitwidth of the signed +-- bit-vector result. +genEvalMode :: String -> [TheoryToUnify] -> DecsQ +genEvalMode nm theories = do + modeName <- newName "mode" + let modeType = VarT modeName + baseConstraint <- [t|EvalModeBase $(return modeType)|] + basicConstraints <- concat <$> traverse (nonFuncConstraint modeType) nonFuncs + funcInstances <- concat <$> traverse (genUnifiedFunInstance nm) funcs + let instanceNames = ("All" ++) . unifiedFunInstanceName nm <$> funcs + funcConstraints <- traverse (genFunConstraint (return modeType)) instanceNames + r <- + classD + (return $ baseConstraint : basicConstraints ++ funcConstraints) + (mkName nm) + [kindedTV modeName (ConT ''EvalModeTag)] + [] + [] + rc <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'C)) [] + rs <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'S)) [] + m <- newName "m" + let mType = varT m + monad <- + tySynD + (mkName $ "Monad" ++ nm) + [ kindedTV modeName (ConT ''EvalModeTag), + kindedTV m (AppT (AppT ArrowT StarT) StarT) + ] + [t| + ( $(appT (conT $ mkName nm) (return modeType)), + Monad $mType, + TryMerge $mType, + UnifiedBranching $(return modeType) $mType + ) + |] + return $ funcInstances ++ [r, rc, rs, monad] + where + nonFuncs = + nub $ + (\x -> if x == UIntN then UWordN else x) + <$> filter (not . isUFun) (theories ++ concat funcs) + funcs = + nub $ + mapMaybe + ( \case + UFun x -> Just x + _ -> Nothing + ) + theories + nonFuncConstraint mode UInteger = + (: []) <$> [t|EvalModeInteger $(return mode)|] + nonFuncConstraint mode UAlgReal = + (: []) <$> [t|EvalModeAlgReal $(return mode)|] + nonFuncConstraint mode UWordN = + (: []) <$> [t|EvalModeBV $(return mode)|] + nonFuncConstraint mode UFP = (: []) <$> [t|EvalModeFP $(return mode)|] + nonFuncConstraint _ _ = return [] + genFunConstraint mode name = appT (conT (mkName name)) mode diff --git a/src/Grisette/Internal/Internal/Decl/Unified/FPFPConversion.hs b/src/Grisette/Internal/Internal/Decl/Unified/FPFPConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/FPFPConversion.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.FPFPConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.FPFPConversion + ( UnifiedFPFPConversionImpl, + UnifiedFPFPConversion, + AllUnifiedFPFPConversion, + ) +where + +import Grisette.Internal.Core.Data.Class.IEEEFP (IEEEFPConvertible) +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP + ( UnifiedFPImpl (GetFP, GetFPRoundingMode), + ) +import Grisette.Internal.SymPrim.FP (ValidFP) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) + +-- | Implementation for 'UnifiedFPFPConversion'. +class + ( UnifiedFPImpl mode fpn eb0 sb0 fp0 fprd, + UnifiedFPImpl mode fpn eb1 sb1 fp1 fprd, + IEEEFPConvertible fp0 fp1 fprd + ) => + UnifiedFPFPConversionImpl + (mode :: EvalModeTag) + fpn + eb0 + sb0 + eb1 + sb1 + fp0 + fp1 + fprd + +-- | Unified constraints for conversion from floating point numbers to floating +-- point numbers. +class + ( UnifiedFPFPConversionImpl + (mode :: EvalModeTag) + (GetFP mode) + eb0 + sb0 + eb1 + sb1 + (GetFP mode eb0 sb0) + (GetFP mode eb1 sb1) + (GetFPRoundingMode mode) + ) => + UnifiedFPFPConversion mode eb0 sb0 eb1 sb1 + +-- | Evaluation mode with unified conversion from floating-points to +-- floating-points. +class + ( forall eb0 sb0 eb1 sb1. + (ValidFP eb0 sb0, ValidFP eb1 sb1) => + UnifiedFPFPConversion + mode + eb0 + sb0 + eb1 + sb1 + ) => + AllUnifiedFPFPConversion mode diff --git a/src/Grisette/Internal/Internal/Decl/Unified/UnifiedBV.hs b/src/Grisette/Internal/Internal/Decl/Unified/UnifiedBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/UnifiedBV.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.UnifiedBV +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.UnifiedBV + ( SomeBVPair, + UnifiedBVImpl (GetIntN, GetWordN), + SafeUnifiedBVImpl, + SafeUnifiedSomeBVImpl, + SafeUnifiedSomeBV, + UnifiedBV, + GetSomeWordN, + GetSomeIntN, + SafeUnifiedBV, + AllUnifiedBV, + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Except (MonadError) +import Data.Bits (Bits, FiniteBits) +import Data.Kind (Constraint, Type) +import GHC.TypeNats (KnownNat, Nat, type (<=)) +import Grisette.Internal.Core.Data.Class.BitCast (BitCast) +import Grisette.Internal.Core.Data.Class.BitVector (BV, SizedBV) +import Grisette.Internal.Core.Data.Class.SafeDiv (DivOr) +import Grisette.Internal.Core.Data.Class.SignConversion (SignConversion) +import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBV, + SomeBVException, + SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.Unified.BaseConstraint (ConSymConversion) +import Grisette.Internal.Unified.Class.UnifiedFiniteBits + ( UnifiedFiniteBits, + ) +import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) +import Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (ConType), + UnifiedSymRep (SymType), + ) +import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv) +import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith + ( UnifiedSafeLinearArith, + ) +import Grisette.Internal.Unified.Class.UnifiedSafeSymRotate + ( UnifiedSafeSymRotate, + ) +import Grisette.Internal.Unified.Class.UnifiedSafeSymShift (UnifiedSafeSymShift) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) +import Grisette.Internal.Unified.UnifiedAlgReal (GetAlgReal) +import Grisette.Internal.Unified.UnifiedInteger (GetInteger) +import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim, UnifiedPrim) + +type BVConstraint mode word int = + ( Num word, + Num int, + Bits word, + Bits int, + FiniteBits word, + FiniteBits int, + SymShift word, + SymShift int, + SymRotate word, + SymRotate int, + SignConversion word int, + UnifiedFiniteBits mode word, + UnifiedFiniteBits mode int + ) :: + Constraint + +-- | Constraints for a pair of non-sized-tagged bit vector types. +type SomeBVPair mode word int = + ( UnifiedPrim mode word, + UnifiedPrim mode int, + BVConstraint mode word int, + BV word, + BV int, + DivOr word, + DivOr int, + ConSymConversion SomeWordN SomeSymWordN word, + ConSymConversion SomeIntN SomeSymIntN int + ) :: + Constraint + +-- | Implementation for 'UnifiedBV'. +class + ( UnifiedConRep word, + UnifiedSymRep int, + ConType word ~ WordN n, + SymType word ~ SymWordN n, + ConType int ~ IntN n, + SymType int ~ SymIntN n, + UnifiedBasicPrim mode word, + UnifiedBasicPrim mode int, + BVConstraint mode word int, + wordn ~ GetWordN mode, + intn ~ GetIntN mode, + word ~ wordn n, + int ~ intn n, + BitCast word int, + BitCast int word, + DivOr word, + DivOr int, + UnifiedFromIntegral mode (GetInteger mode) word, + UnifiedFromIntegral mode (GetInteger mode) int, + UnifiedFromIntegral mode word (GetInteger mode), + UnifiedFromIntegral mode word (GetAlgReal mode), + UnifiedFromIntegral mode int (GetInteger mode), + UnifiedFromIntegral mode int (GetAlgReal mode), + ConSymConversion (WordN n) (SymWordN n) word, + ConSymConversion (IntN n) (SymIntN n) int + ) => + UnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int + | wordn -> intn, + intn -> wordn, + wordn n -> word, + word -> wordn n, + intn n -> int, + int -> intn n + where + -- | Get a unified unsigned size-tagged bit vector type. Resolves to 'WordN' + -- in 'Grisette.Unified.C' mode, and 'SymWordN' in 'Grisette.Unified.S' mode. + type GetWordN mode = (w :: Nat -> Type) | w -> mode + + -- | Get a unified signed size-tagged bit vector type. Resolves to 'IntN' + -- in 'Grisette.Unified.C' mode, and 'SymIntN' in 'Grisette.Unified.S' mode. + type GetIntN mode = (i :: Nat -> Type) | i -> mode + +-- | Get a unified unsigned dynamic bit width bit vector type. Resolves to +-- 'SomeWordN' in 'Grisette.Unified.C' mode, and 'SomeSymWordN' in +-- 'Grisette.Unified.S' mode. +type family GetSomeWordN mode = sw | sw -> mode where + GetSomeWordN mode = SomeBV (GetWordN mode) + +-- | Get a unified signed dynamic bit width bit vector type. Resolves to +-- 'SomeIntN' in 'Grisette.Unified.C' mode, and 'SomeSymIntN' in +-- 'Grisette.Unified.S' mode. +type family GetSomeIntN mode = sw | sw -> mode where + GetSomeIntN mode = SomeBV (GetIntN mode) + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Internal.Unified.EvalMode.EvalMode'. +class + ( UnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + ) => + UnifiedBV mode n + +-- | Implementation for 'SafeUnifiedBV'. +class + ( UnifiedSafeDiv mode ArithException word m, + UnifiedSafeLinearArith mode ArithException word m, + UnifiedSafeSymShift mode ArithException word m, + UnifiedSafeSymRotate mode ArithException word m, + UnifiedSafeDiv mode ArithException int m, + UnifiedSafeLinearArith mode ArithException int m, + UnifiedSafeSymShift mode ArithException int m, + UnifiedSafeSymRotate mode ArithException int m, + UnifiedBVImpl mode wordn intn n word int + ) => + SafeUnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int m + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Internal.Unified.EvalMode.EvalMode'. +class + ( SafeUnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + m + ) => + SafeUnifiedBV mode n m + +-- | Implementation for 'SafeUnifiedSomeBV'. +class + ( SomeBVPair mode word int, + UnifiedSafeDiv mode (Either SomeBVException ArithException) word m, + UnifiedSafeLinearArith mode (Either SomeBVException ArithException) word m, + UnifiedSafeSymRotate mode (Either SomeBVException ArithException) word m, + UnifiedSafeSymShift mode (Either SomeBVException ArithException) word m, + UnifiedSafeDiv mode (Either SomeBVException ArithException) int m, + UnifiedSafeLinearArith mode (Either SomeBVException ArithException) int m, + UnifiedSafeSymRotate mode (Either SomeBVException ArithException) int m, + UnifiedSafeSymShift mode (Either SomeBVException ArithException) int m + ) => + SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Internal.Unified.EvalMode.EvalMode'. +class + ( SafeUnifiedSomeBVImpl + mode + (SomeBV (GetWordN mode)) + (SomeBV (GetIntN mode)) + m + ) => + SafeUnifiedSomeBV mode m + +-- | Evaluation mode with unified bit vector types. +class + ( forall n m. + ( UnifiedBranching mode m, + MonadError ArithException m, + KnownNat n, + 1 <= n + ) => + SafeUnifiedBV mode n m, + forall m. + ( UnifiedBranching mode m, + MonadError (Either SomeBVException ArithException) m + ) => + SafeUnifiedSomeBV mode m, + forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n, + SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode), + SizedBV (GetWordN mode), + SizedBV (GetIntN mode) + ) => + AllUnifiedBV mode diff --git a/src/Grisette/Internal/Internal/Decl/Unified/UnifiedBool.hs b/src/Grisette/Internal/Internal/Decl/Unified/UnifiedBool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/UnifiedBool.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.UnifiedBool +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.UnifiedBool + ( UnifiedBool (..), + ) +where + +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymPrim (Prim) +import Grisette.Internal.Unified.BaseConstraint + ( ConSymConversion, + ) +import Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (ConType), + UnifiedSymRep (SymType), + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) + +-- | Evaluation mode with unified 'Bool' type. +class + ( Prim (GetBool mode), + UnifiedConRep (GetBool mode), + UnifiedSymRep (GetBool mode), + ConType (GetBool mode) ~ Bool, + SymType (GetBool mode) ~ SymBool, + ConSymConversion Bool SymBool (GetBool mode), + LogicalOp (GetBool mode) + ) => + UnifiedBool (mode :: EvalModeTag) + where + -- | Get a unified Boolean type. Resolves to 'Bool' in 'Grisette.Unified.C' + -- mode, and 'SymBool' in 'Grisette.Unified.S' mode. + type GetBool mode = bool | bool -> mode diff --git a/src/Grisette/Internal/Internal/Decl/Unified/UnifiedFP.hs b/src/Grisette/Internal/Internal/Decl/Unified/UnifiedFP.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Decl/Unified/UnifiedFP.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Decl.Unified.UnifiedFP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Decl.Unified.UnifiedFP + ( UnifiedFP, + SafeUnifiedFP, + AllUnifiedFP, + UnifiedFPImpl (GetFP, GetFPRoundingMode), + SafeUnifiedFPImpl, + ) +where + +import Control.Monad.Error.Class (MonadError) +import Data.Kind (Type) +import GHC.TypeNats (Nat) +import Grisette.Internal.Core.Data.Class.IEEEFP + ( IEEEFPConstants, + IEEEFPConvertible, + IEEEFPOp, + IEEEFPRoundingOp, + IEEEFPToAlgReal, + ) +import Grisette.Internal.Core.Data.Class.SymIEEEFP (SymIEEEFPTraits) +import Grisette.Internal.SymPrim.FP (FP, NotRepresentableFPError, ValidFP) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.Unified.BaseConstraint (ConSymConversion) +import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) +import Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (ConType), + UnifiedSymRep (SymType), + ) +import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) +import Grisette.Internal.Unified.UnifiedAlgReal (GetAlgReal) +import Grisette.Internal.Unified.UnifiedInteger (GetInteger) +import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim) + +-- | Implementation for 'UnifiedFP'. +class + ( UnifiedConRep fp, + UnifiedSymRep fp, + ConType fp ~ FP eb sb, + SymType fp ~ SymFP eb sb, + UnifiedBasicPrim mode fp, + Floating fp, + SymIEEEFPTraits fp, + IEEEFPConstants fp, + IEEEFPOp fp, + IEEEFPRoundingOp fp rd, + UnifiedFromIntegral mode (GetInteger mode) fp, + IEEEFPToAlgReal (GetAlgReal mode) fp rd, + IEEEFPConvertible (GetInteger mode) fp rd, + ConSymConversion (FP eb sb) (SymFP eb sb) fp, + fpn ~ GetFP mode, + fp ~ fpn eb sb, + rd ~ GetFPRoundingMode mode + ) => + UnifiedFPImpl (mode :: EvalModeTag) fpn eb sb fp rd + | fpn eb sb -> fp rd, + fp -> fpn eb sb rd, + rd -> fpn, + rd eb sb -> fp + where + -- | Get a unified floating point type. Resolves to 'FP' in + -- 'Grisette.Unified.C' mode, and 'SymFP' in 'Grisette.Unified.S' mode. + type GetFP mode = (f :: Nat -> Nat -> Type) | f -> mode + + -- | Get a unified floating point rounding mode type. Resolves to + -- 'Grisette.FPRoundingMode' in 'Grisette.Unified.C' mode, and + -- 'Grisette.SymFPRoundingMode' in 'Grisette.Unified.S' mode. + type GetFPRoundingMode mode = r | r -> mode + +-- | Evaluation mode with unified 'FP' type. +class + ( UnifiedFPImpl + mode + (GetFP mode) + eb + sb + (GetFP mode eb sb) + (GetFPRoundingMode mode) + ) => + UnifiedFP mode eb sb + +-- | Implementation for 'SafeUnifiedFP'. +class + (UnifiedFPImpl mode fpn eb sb fp rd) => + SafeUnifiedFPImpl mode fpn eb sb fp rd (m :: Type -> Type) + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Internal.Unified.EvalMode.EvalMode'. +class + ( SafeUnifiedFPImpl + mode + (GetFP mode) + eb + sb + (GetFP mode eb sb) + (GetFPRoundingMode mode) + m, + UnifiedSafeFromFP + mode + NotRepresentableFPError + (GetInteger mode) + (GetFP mode eb sb) + (GetFPRoundingMode mode) + m + ) => + SafeUnifiedFP mode eb sb m + +-- | Evaluation mode with unified floating point type. +class + ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb, + forall eb sb m. + ( ValidFP eb sb, + UnifiedBranching mode m, + MonadError NotRepresentableFPError m + ) => + SafeUnifiedFP mode eb sb m + ) => + AllUnifiedFP mode diff --git a/src/Grisette/Internal/Internal/Impl/Core/Control/Monad/Union.hs b/src/Grisette/Internal/Internal/Impl/Core/Control/Monad/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Control/Monad/Union.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# HLINT ignore "Use <&>" #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Control.Monad.Union +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Control.Monad.Union + ( -- * Union and helpers + unionUnaryOp, + unionBinOp, + liftUnion, + liftToMonadUnion, + unionMergingStrategy, + isMerged, + unionSize, + IsConcrete, + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import Control.Monad.Identity (Identity (Identity, runIdentity)) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Data.Functor.Classes + ( Eq1 (liftEq), + Show1 (liftShowsPrec), + showsPrec1, + ) +import qualified Data.HashMap.Lazy as HML +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable.Lifted (Hashable1 (liftHashWithSalt), hashWithSalt1) +import qualified Data.Serialize as Cereal +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.EvalSym + ( EvalSym (evalSym), + EvalSym1 (liftEvalSym), + evalSym1, + ) +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (extractSymMaybe), + ExtractSym1 (liftExtractSymMaybe), + extractSymMaybe1, + ) +import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (false, symImplies, symNot, symXor, true, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + MergingStrategy (SimpleStrategy), + ) +import Grisette.Internal.Core.Data.Class.PPrint + ( PPrint (pformatPrec), + PPrint1 (liftPFormatPrec), + groupedEnclose, + pformatPrec1, + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con), + ) +import Grisette.Internal.Core.Data.Class.Solver + ( UnionWithExcept (extractUnionExcept), + ) +import Grisette.Internal.Core.Data.Class.SubstSym + ( SubstSym (substSym), + SubstSym1 (liftSubstSym), + substSym1, + ) +import Grisette.Internal.Core.Data.Class.ToCon + ( ToCon (toCon), + ToCon1 (liftToCon), + toCon1, + ) +import Grisette.Internal.Core.Data.Class.ToSym + ( ToSym (toSym), + ToSym1 (liftToSym), + toSym1, + ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( mrgSingle, + mrgSingleWithStrategy, + tryMerge, + ) +import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union + ( Union (UAny, UMrg), + unionBase, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( SymEq ((.==)), + SymEq1 (liftSymEq), + symEq1, + ) +import Grisette.Internal.Internal.Decl.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + ) +import Grisette.Internal.Internal.Impl.Core.Data.UnionBase () +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (allSymsS), + AllSyms1 (liftAllSymsS), + allSymsS1, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun + ( type (-->), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedNonFuncPrim, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) +import Language.Haskell.TH.Syntax.Compat (unTypeSplice) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +instance (Mergeable a, Serial a) => Serial (Union a) where + serialize = serialize . unionBase + deserialize = UMrg rootStrategy <$> deserialize + +instance (Mergeable a, Serial a) => Cereal.Serialize (Union a) where + put = serialize + get = deserialize + +instance (Mergeable a, Serial a) => Binary.Binary (Union a) where + put = serialize + get = deserialize + +-- | Get the (possibly empty) cached merging strategy. +unionMergingStrategy :: Union a -> Maybe (MergingStrategy a) +unionMergingStrategy (UMrg s _) = Just s +unionMergingStrategy _ = Nothing + +instance (NFData a) => NFData (Union a) where + rnf = rnf1 + +instance NFData1 Union where + liftRnf _a (UAny m) = liftRnf _a m + liftRnf _a (UMrg _ m) = liftRnf _a m + +instance (Lift a) => Lift (Union a) where + liftTyped (UAny v) = [||UAny v||] + liftTyped (UMrg _ v) = [||UAny v||] + lift = unTypeSplice . liftTyped + +instance (Show a) => (Show (Union a)) where + showsPrec = showsPrec1 + +liftShowsPrecUnion :: + forall a. + (Int -> a -> ShowS) -> + ([a] -> ShowS) -> + Int -> + UnionBase a -> + ShowS +liftShowsPrecUnion sp _ i (UnionSingle a) = sp i a +liftShowsPrecUnion sp sl i (UnionIf _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrecUnion sp sl + +wrapBracket :: Char -> Char -> ShowS -> ShowS +wrapBracket l r p = showChar l . p . showChar r + +instance Show1 Union where + liftShowsPrec sp sl _ (UAny a) = + wrapBracket '<' '>' + . liftShowsPrecUnion sp sl 0 + $ a + liftShowsPrec sp sl _ (UMrg _ a) = + wrapBracket '{' '}' + . liftShowsPrecUnion sp sl 0 + $ a + +instance (PPrint a) => PPrint (Union a) where + pformatPrec = pformatPrec1 + +instance PPrint1 Union where + liftPFormatPrec fa fl _ = \case + (UAny a) -> groupedEnclose "<" ">" $ liftPFormatPrec fa fl 0 a + (UMrg _ a) -> groupedEnclose "{" "}" $ liftPFormatPrec fa fl 0 a + +-- | Check if a 'Union' is already merged. +isMerged :: Union a -> Bool +isMerged UAny {} = False +isMerged UMrg {} = True +{-# INLINE isMerged #-} + +-- | Lift a unary operation to 'Union'. +unionUnaryOp :: (a -> a) -> Union a -> Union a +unionUnaryOp f a = do + a1 <- a + maybe return mrgSingleWithStrategy (unionMergingStrategy a) $ f a1 +{-# INLINE unionUnaryOp #-} + +-- | Lift a binary operation to 'Union'. +unionBinOp :: + (a -> a -> a) -> + Union a -> + Union a -> + Union a +unionBinOp f a b = do + a1 <- a + b1 <- b + maybe + return + mrgSingleWithStrategy + (unionMergingStrategy a <|> unionMergingStrategy b) + $ f a1 b1 +{-# INLINE unionBinOp #-} + +instance (SymEq a) => SymEq (Union a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance SymEq1 Union where + liftSymEq f x y = simpleMerge $ f <$> x <*> y + {-# INLINE liftSymEq #-} + +-- | Lift the 'Union' to any Applicative 'SymBranching'. +liftUnion :: + forall u a. (Mergeable a, SymBranching u, Applicative u) => Union a -> u a +liftUnion u = go (unionBase u) + where + go :: UnionBase a -> u a + go (UnionSingle v) = mrgSingle v + go (UnionIf _ _ c t f) = mrgIf c (go t) (go f) + +-- | Alias for `liftUnion`, but for monads. +liftToMonadUnion :: (Mergeable a, MonadUnion u) => Union a -> u a +liftToMonadUnion = liftUnion + +instance (ToSym a b) => ToSym (Union a) (Union b) where + toSym = toSym1 + +instance ToSym1 Union Union where + liftToSym = fmap + +instance (ToSym a b) => ToSym (Identity a) (Union b) where + toSym = toSym1 + +instance ToSym1 Identity Union where + liftToSym f v = return $ runIdentity $ fmap f v + +instance ToSym (Union Bool) SymBool where + toSym = simpleMerge . fmap con + +instance ToSym (Union Integer) SymInteger where + toSym = simpleMerge . fmap con + +instance (KnownNat n, 1 <= n) => ToSym (Union (IntN n)) (SymIntN n) where + toSym = simpleMerge . fmap con + +instance (KnownNat n, 1 <= n) => ToSym (Union (WordN n)) (SymWordN n) where + toSym = simpleMerge . fmap con + +instance + ( SupportedPrim ((=->) ca cb), + SupportedNonFuncPrim ca, + LinkedRep ca sa, + LinkedRep cb sb + ) => + ToSym (Union ((=->) ca cb)) ((=~>) sa sb) + where + toSym = simpleMerge . fmap con + +instance + ( SupportedPrim ((-->) ca cb), + SupportedNonFuncPrim ca, + LinkedRep ca sa, + LinkedRep cb sb + ) => + ToSym (Union ((-->) ca cb)) ((-~>) sa sb) + where + toSym = simpleMerge . fmap con + +instance (ToCon a b) => ToCon (Union a) (Identity b) where + toCon = toCon1 + +instance ToCon1 Union Identity where + liftToCon f v = go $ unionBase v + where + go (UnionSingle x) = Identity <$> f x + go (UnionIf _ _ c t f) = + case toCon c of + Nothing -> Nothing + Just True -> go t + Just False -> go f + +instance (ToCon a b) => ToCon (Union a) (Union b) where + toCon = toCon1 + +instance ToCon1 Union Union where + liftToCon f v = go $ unionBase v + where + go (UnionSingle x) = case f x of + Nothing -> Nothing + Just v -> Just $ return v + go (UnionIf _ _ c t f) = do + t' <- go t + f' <- go f + return $ mrgIfPropagatedStrategy c t' f' + +instance (EvalSym a) => EvalSym (Union a) where + evalSym = evalSym1 + +instance EvalSym1 Union where + liftEvalSym f fillDefault model x = go $ unionBase x + where + go (UnionSingle v) = single $ f fillDefault model v + go (UnionIf _ _ cond t f) = + unionIf (evalSym fillDefault model cond) (go t) (go f) + strategy = unionMergingStrategy x + single = maybe return mrgSingleWithStrategy strategy + unionIf = maybe mrgIfPropagatedStrategy mrgIfWithStrategy strategy + +instance (SubstSym a) => SubstSym (Union a) where + substSym = substSym1 + +instance SubstSym1 Union where + liftSubstSym f sym val x = go $ unionBase x + where + go (UnionSingle v) = single $ f sym val v + go (UnionIf _ _ cond t f) = + unionIf + (substSym sym val cond) + (go t) + (go f) + strategy = unionMergingStrategy x + single = maybe return mrgSingleWithStrategy strategy + unionIf = maybe mrgIfPropagatedStrategy mrgIfWithStrategy strategy + +instance (ExtractSym a) => ExtractSym (Union a) where + extractSymMaybe = extractSymMaybe1 + +instance ExtractSym1 Union where + liftExtractSymMaybe e v = go $ unionBase v + where + go (UnionSingle x) = e x + go (UnionIf _ _ cond t f) = extractSymMaybe cond <> go t <> go f + +instance (Hashable a) => Hashable (Union a) where + hashWithSalt = hashWithSalt1 + +instance Hashable1 Union where + liftHashWithSalt f s (UAny u) = + liftHashWithSalt f (s `hashWithSalt` (0 :: Int)) u + liftHashWithSalt f s (UMrg _ u) = + liftHashWithSalt f (s `hashWithSalt` (1 :: Int)) u + +instance (Eq a) => Eq (Union a) where + UAny l == UAny r = l == r + UMrg _ l == UMrg _ r = l == r + _ == _ = False + +instance Eq1 Union where + liftEq e l r = liftEq e (unionBase l) (unionBase r) + +instance (Num a, Mergeable a) => Num (Union a) where + fromInteger = mrgSingle . fromInteger + negate = tryMerge . unionUnaryOp negate + l + r = tryMerge $ unionBinOp (+) l r + l * r = tryMerge $ unionBinOp (*) l r + l - r = tryMerge $ unionBinOp (-) l r + abs = tryMerge . unionUnaryOp abs + signum = tryMerge . unionUnaryOp signum + +instance (ITEOp a, Mergeable a) => ITEOp (Union a) where + symIte = mrgIf + +instance (LogicalOp a, Mergeable a) => LogicalOp (Union a) where + true = mrgSingle true + false = mrgSingle false + l .|| r = tryMerge $ unionBinOp (.||) l r + l .&& r = tryMerge $ unionBinOp (.&&) l r + symNot = tryMerge . unionUnaryOp symNot + symXor l r = tryMerge $ unionBinOp symXor l r + symImplies l r = tryMerge $ unionBinOp symImplies l r + +instance + (Function f arg ret, Mergeable f, Mergeable ret) => + Function (Union f) arg (Union ret) + where + f # a = do + f1 <- f + mrgSingle $ f1 # a + +-- AllSyms +instance (AllSyms a) => AllSyms (Union a) where + allSymsS = allSymsS1 + +instance AllSyms1 Union where + liftAllSymsS f = liftAllSymsS f . unionBase + +-- Concrete Key HashMaps + +-- | Tag for concrete types. +-- Useful for specifying the merge strategy for some parametrized types where we should have different +-- merge strategy for symbolic and concrete ones. +class (Eq t, Ord t, Hashable t) => IsConcrete t + +instance IsConcrete Bool + +instance IsConcrete Integer + +instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (Union (Maybe t))) where + rootStrategy = SimpleStrategy mrgIte + +instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (Union (Maybe t))) where + mrgIte cond l r = + HML.unionWith (mrgIf cond) ul ur + where + ul = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + l + (HML.keys r) + ur = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + r + (HML.keys l) + +instance UnionWithExcept (Union (Either e v)) Union e v where + extractUnionExcept = id + +-- | The size of a union is defined as the number of branches. +-- For example, +-- +-- >>> unionSize (return True) +-- 1 +-- >>> unionSize (mrgIf "a" (return 1) (return 2) :: Union Integer) +-- 2 +-- >>> unionSize (choose [1..7] "a" :: Union Integer) +-- 7 +unionSize :: Union a -> Int +unionSize = unionSize' . unionBase + where + unionSize' (UnionSingle _) = 1 + unionSize' (UnionIf _ _ _ l r) = unionSize' l + unionSize' r diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/EvalSym.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/EvalSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/EvalSym.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.EvalSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.EvalSym () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import qualified Data.HashSet as HS +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import Data.Ord (Down) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio, denominator, numerator, (%)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import Generics.Deriving.Instances () +import qualified Generics.Deriving.Monoid as Monoid +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym + ( EvalSym (evalSym), + EvalSym1 (liftEvalSym), + EvalSym2, + evalSym1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.Model (evalTerm) +import Grisette.Internal.SymPrim.Prim.Term + ( SymRep (SymType), + someTypedSymbol, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +#define CONCRETE_EVALUATESYM(type) \ +instance EvalSym type where \ + evalSym _ _ = id + +#define CONCRETE_EVALUATESYM_BV(type) \ +instance (KnownNat n, 1 <= n) => EvalSym (type n) where \ + evalSym _ _ = id + +#if 1 +CONCRETE_EVALUATESYM(Bool) +CONCRETE_EVALUATESYM(Integer) +CONCRETE_EVALUATESYM(Char) +CONCRETE_EVALUATESYM(Int) +CONCRETE_EVALUATESYM(Int8) +CONCRETE_EVALUATESYM(Int16) +CONCRETE_EVALUATESYM(Int32) +CONCRETE_EVALUATESYM(Int64) +CONCRETE_EVALUATESYM(Word) +CONCRETE_EVALUATESYM(Word8) +CONCRETE_EVALUATESYM(Word16) +CONCRETE_EVALUATESYM(Word32) +CONCRETE_EVALUATESYM(Word64) +CONCRETE_EVALUATESYM(Float) +CONCRETE_EVALUATESYM(Double) +CONCRETE_EVALUATESYM(B.ByteString) +CONCRETE_EVALUATESYM(T.Text) +CONCRETE_EVALUATESYM(FPRoundingMode) +CONCRETE_EVALUATESYM(Monoid.All) +CONCRETE_EVALUATESYM(Monoid.Any) +CONCRETE_EVALUATESYM(Ordering) +CONCRETE_EVALUATESYM_BV(IntN) +CONCRETE_EVALUATESYM_BV(WordN) +CONCRETE_EVALUATESYM(AlgReal) +#endif + +instance EvalSym (Proxy a) where + evalSym _ _ = id + {-# INLINE evalSym #-} + +instance EvalSym1 Proxy where + liftEvalSym _ _ _ = id + {-# INLINE liftEvalSym #-} + +instance (Integral a, EvalSym a) => EvalSym (Ratio a) where + evalSym fillDefault model r = + evalSym fillDefault model (numerator r) + % evalSym fillDefault model (denominator r) + +instance (ValidFP eb fb) => EvalSym (FP eb fb) where + evalSym _ _ = id + +-- Symbolic primitives +#define EVALUATE_SYM_SIMPLE(symtype) \ +instance EvalSym symtype where \ + evalSym fillDefault model (symtype t) = \ + symtype $ evalTerm fillDefault model HS.empty t + +#define EVALUATE_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => EvalSym (symtype n) where \ + evalSym fillDefault model (symtype t) = \ + symtype $ evalTerm fillDefault model HS.empty t + +#define EVALUATE_SYM_FUN(cop, op, cons) \ +instance EvalSym (op sa sb) where \ + evalSym fillDefault model (cons t) = \ + cons $ evalTerm fillDefault model HS.empty t + +#if 1 +EVALUATE_SYM_SIMPLE(SymBool) +EVALUATE_SYM_SIMPLE(SymInteger) +EVALUATE_SYM_SIMPLE(SymFPRoundingMode) +EVALUATE_SYM_SIMPLE(SymAlgReal) +EVALUATE_SYM_BV(SymIntN) +EVALUATE_SYM_BV(SymWordN) +EVALUATE_SYM_FUN((=->), (=~>), SymTabularFun) +EVALUATE_SYM_FUN((-->), (-~>), SymGeneralFun) +#endif + +instance (ValidFP eb sb) => EvalSym (SymFP eb sb) where + evalSym fillDefault model (SymFP t) = + SymFP $ evalTerm fillDefault model HS.empty t + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''EvalSym] + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''EvalSym, ''EvalSym1, ''EvalSym2] + +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''Monoid.Dual, + ''Monoid.First, + ''Monoid.Last, + ''Monoid.Sum, + ''Monoid.Product, + ''Down, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''EvalSym, ''EvalSym1] + +-- IdentityT +instance (EvalSym1 m, EvalSym a) => EvalSym (IdentityT m a) where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance (EvalSym1 m) => EvalSym1 (IdentityT m) where + liftEvalSym f fillDefault model (IdentityT a) = + IdentityT $ liftEvalSym f fillDefault model a + {-# INLINE liftEvalSym #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (EvalSym (l a), EvalSym (r a)) => EvalSym (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (EvalSym1 l, EvalSym1 r) => EvalSym1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (EvalSym (l a), EvalSym (r a)) => EvalSym (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (EvalSym1 l, EvalSym1 r) => EvalSym1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (EvalSym (f (g a))) => EvalSym (Compose f g a) + +instance (EvalSym1 f, EvalSym1 g) => EvalSym1 (Compose f g) where + liftEvalSym f fillDefault m (Compose l) = + Compose $ liftEvalSym (liftEvalSym f) fillDefault m l + {-# INLINE liftEvalSym #-} + +-- Const +deriving via (Default (Const a b)) instance (EvalSym a) => EvalSym (Const a b) + +deriving via (Default1 (Const a)) instance (EvalSym a) => EvalSym1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (EvalSym (f a)) => EvalSym (Alt f a) + +deriving via (Default1 (Alt f)) instance (EvalSym1 f) => EvalSym1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (EvalSym (f a)) => EvalSym (Ap f a) + +deriving via (Default1 (Ap f)) instance (EvalSym1 f) => EvalSym1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance EvalSym (U1 p) + +deriving via (Default (V1 p)) instance EvalSym (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (EvalSym c) => EvalSym (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (EvalSym (f p)) => EvalSym (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (EvalSym (f p), EvalSym (g p)) => EvalSym ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (EvalSym (f p), EvalSym (g p)) => EvalSym ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (EvalSym p) => EvalSym (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (EvalSym (f p)) => EvalSym (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (EvalSym (f (g p))) => EvalSym ((f :.: g) p) + +instance (EvalSym a, EvalSym b) => EvalSym (a =-> b) where + evalSym fillDefault model (TabularFun s t) = + TabularFun + (evalSym fillDefault model s) + (evalSym fillDefault model t) + +instance (EvalSym (SymType b)) => EvalSym (a --> b) where + evalSym fillDefault model (GeneralFun s t) = + GeneralFun s $ + evalTerm fillDefault model (HS.singleton $ someTypedSymbol s) t diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ExtractSym.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ExtractSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ExtractSym.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=extractsym #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import qualified Data.HashSet as HS +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.Text as T +import Data.Typeable (Proxy, type (:~~:) (HRefl)) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + type (:*:), + type (:+:), + type (:.:) (Comp1), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym + ( ExtractSym (extractSymMaybe), + ExtractSym1 (liftExtractSymMaybe), + ExtractSym2, + extractSymMaybe1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.Model + ( SymbolSet (SymbolSet), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( IsSymbolKind (decideSymbolKind), + SymRep (SymType), + someTypedSymbol, + ) +import Grisette.Internal.SymPrim.Prim.TermUtils (extractTerm) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Lib.Base +-- >>> import Data.HashSet as HashSet +-- >>> import Data.List (sort) + +#define CONCRETE_EXTRACT_SYMBOLICS(type) \ +instance ExtractSym type where \ + extractSymMaybe _ = return mempty + +#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \ +instance (KnownNat n, 1 <= n) => ExtractSym (type n) where \ + extractSymMaybe _ = return mempty + +#if 1 +CONCRETE_EXTRACT_SYMBOLICS(Bool) +CONCRETE_EXTRACT_SYMBOLICS(Integer) +CONCRETE_EXTRACT_SYMBOLICS(Char) +CONCRETE_EXTRACT_SYMBOLICS(Int) +CONCRETE_EXTRACT_SYMBOLICS(Int8) +CONCRETE_EXTRACT_SYMBOLICS(Int16) +CONCRETE_EXTRACT_SYMBOLICS(Int32) +CONCRETE_EXTRACT_SYMBOLICS(Int64) +CONCRETE_EXTRACT_SYMBOLICS(Word) +CONCRETE_EXTRACT_SYMBOLICS(Word8) +CONCRETE_EXTRACT_SYMBOLICS(Word16) +CONCRETE_EXTRACT_SYMBOLICS(Word32) +CONCRETE_EXTRACT_SYMBOLICS(Word64) +CONCRETE_EXTRACT_SYMBOLICS(Float) +CONCRETE_EXTRACT_SYMBOLICS(Double) +CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) +CONCRETE_EXTRACT_SYMBOLICS(T.Text) +CONCRETE_EXTRACT_SYMBOLICS(FPRoundingMode) +CONCRETE_EXTRACT_SYMBOLICS(Monoid.All) +CONCRETE_EXTRACT_SYMBOLICS(Monoid.Any) +CONCRETE_EXTRACT_SYMBOLICS(Ordering) +CONCRETE_EXTRACT_SYMBOLICS_BV(WordN) +CONCRETE_EXTRACT_SYMBOLICS_BV(IntN) +CONCRETE_EXTRACT_SYMBOLICS(AlgReal) +#endif + +instance ExtractSym (Proxy a) where + extractSymMaybe _ = return mempty + {-# INLINE extractSymMaybe #-} + +instance ExtractSym1 Proxy where + liftExtractSymMaybe _ _ = return mempty + {-# INLINE liftExtractSymMaybe #-} + +instance (ExtractSym a) => ExtractSym (Ratio a) where + extractSymMaybe a = + extractSymMaybe (numerator a) <> extractSymMaybe (denominator a) + {-# INLINE extractSymMaybe #-} + +instance (ValidFP eb sb) => ExtractSym (FP eb sb) where + extractSymMaybe _ = return mempty + +#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \ +instance ExtractSym symtype where \ + extractSymMaybe :: \ + forall knd. (IsSymbolKind knd) => symtype -> Maybe (SymbolSet knd); \ + extractSymMaybe (symtype t) = \ + case decideSymbolKind @knd of\ + Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \ + Right HRefl -> SymbolSet <$> extractTerm HS.empty t + +#define EXTRACT_SYMBOLICS_BV(symtype) \ +instance (KnownNat n, 1 <= n) => ExtractSym (symtype n) where \ + extractSymMaybe :: \ + forall knd. (IsSymbolKind knd) => symtype n -> Maybe (SymbolSet knd); \ + extractSymMaybe (symtype t) = \ + case decideSymbolKind @knd of\ + Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \ + Right HRefl -> SymbolSet <$> extractTerm HS.empty t + +#define EXTRACT_SYMBOLICS_FUN(op, cons) \ +instance ExtractSym (op sa sb) where \ + extractSymMaybe :: \ + forall knd. (IsSymbolKind knd) => op sa sb -> Maybe (SymbolSet knd); \ + extractSymMaybe (cons t) = \ + case decideSymbolKind @knd of \ + Left HRefl -> Nothing; \ + Right HRefl -> SymbolSet <$> extractTerm HS.empty t + +#if 1 +EXTRACT_SYMBOLICS_SIMPLE(SymBool) +EXTRACT_SYMBOLICS_SIMPLE(SymInteger) +EXTRACT_SYMBOLICS_SIMPLE(SymFPRoundingMode) +EXTRACT_SYMBOLICS_SIMPLE(SymAlgReal) +EXTRACT_SYMBOLICS_BV(SymIntN) +EXTRACT_SYMBOLICS_BV(SymWordN) +EXTRACT_SYMBOLICS_FUN((=~>), SymTabularFun) +EXTRACT_SYMBOLICS_FUN((-~>), SymGeneralFun) +#endif + +instance (ValidFP eb fb) => ExtractSym (SymFP eb fb) where + extractSymMaybe :: + forall knd. (IsSymbolKind knd) => SymFP eb fb -> Maybe (SymbolSet knd) + extractSymMaybe (SymFP t) = + case decideSymbolKind @knd of + Left HRefl -> SymbolSet <$> extractTerm HS.empty t + Right HRefl -> SymbolSet <$> extractTerm HS.empty t + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''ExtractSym] + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''ExtractSym, ''ExtractSym1, ''ExtractSym2] + +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''Monoid.Dual, + ''Monoid.First, + ''Monoid.Last, + ''Monoid.Sum, + ''Monoid.Product, + ''Down, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''ExtractSym, ''ExtractSym1] + +-- IdentityT +instance + (ExtractSym1 m, ExtractSym a) => + ExtractSym (IdentityT m a) + where + extractSymMaybe = extractSymMaybe1 + {-# INLINE extractSymMaybe #-} + +instance (ExtractSym1 m) => ExtractSym1 (IdentityT m) where + liftExtractSymMaybe f (IdentityT v) = liftExtractSymMaybe f v + {-# INLINE liftExtractSymMaybe #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (ExtractSym (l a), ExtractSym (r a)) => + ExtractSym (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (ExtractSym1 l, ExtractSym1 r) => + ExtractSym1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (ExtractSym (l a), ExtractSym (r a)) => + ExtractSym (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (ExtractSym1 l, ExtractSym1 r) => ExtractSym1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (ExtractSym (f (g a))) => ExtractSym (Compose f g a) + +instance + (ExtractSym1 f, ExtractSym1 g) => + ExtractSym1 (Compose f g) + where + liftExtractSymMaybe f (Compose l) = + liftExtractSymMaybe (liftExtractSymMaybe f) l + {-# INLINE liftExtractSymMaybe #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (ExtractSym a) => ExtractSym (Const a b) + +deriving via + (Default1 (Const a)) + instance + (ExtractSym a) => ExtractSym1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (ExtractSym (f a)) => ExtractSym (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (ExtractSym1 f) => ExtractSym1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (ExtractSym (f a)) => ExtractSym (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (ExtractSym1 f) => ExtractSym1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance ExtractSym (U1 p) + +deriving via (Default (V1 p)) instance ExtractSym (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (ExtractSym c) => ExtractSym (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (ExtractSym (f p)) => ExtractSym (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (ExtractSym (f p), ExtractSym (g p)) => + ExtractSym ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (ExtractSym (f p), ExtractSym (g p)) => + ExtractSym ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (ExtractSym p) => ExtractSym (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (ExtractSym (f p)) => ExtractSym (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (ExtractSym (f (g p))) => ExtractSym ((f :.: g) p) + +instance (ExtractSym a, ExtractSym b) => ExtractSym (a =-> b) where + extractSymMaybe (TabularFun s t) = + extractSymMaybe s <> extractSymMaybe t + +instance (ExtractSym (SymType b)) => ExtractSym (a --> b) where + extractSymMaybe :: forall knd. (IsSymbolKind knd) => (a --> b) -> Maybe (SymbolSet knd) + extractSymMaybe (GeneralFun t f) = + case decideSymbolKind @knd of + Left HRefl -> Nothing + Right HRefl -> SymbolSet <$> extractTerm (HS.singleton $ someTypedSymbol t) f diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/Mergeable.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/Mergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/Mergeable.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=mergeable1 #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable () where + +import Control.Exception + ( ArithException + ( Denormal, + DivideByZero, + LossOfPrecision, + Overflow, + RatioZeroDenominator, + Underflow + ), + ) +import Control.Monad.Cont (ContT (ContT)) +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT, runIdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose, getCompose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap, Endo (Endo, appEndo)) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Ratio (Ratio) +import qualified Data.Text as T +import Data.Typeable (Proxy, Typeable) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (+), type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.BitCast (bitCastOrCanonical) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + Mergeable2 (liftRootStrategy2), + Mergeable3 (liftRootStrategy3), + MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), + StrategyList (StrategyList), + buildStrategyList, + rootStrategy1, + wrapStrategy, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal, AlgRealPoly, RealPoint) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + withValidFPProofs, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) +import Unsafe.Coerce (unsafeCoerce) + +#define CONCRETE_ORD_MERGEABLE(type) \ +instance Mergeable type where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub + +#define CONCRETE_ORD_MERGEABLE_BV(type) \ +instance (KnownNat n, 1 <= n) => Mergeable (type n) where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub + +#if 1 +CONCRETE_ORD_MERGEABLE(Bool) +CONCRETE_ORD_MERGEABLE(Integer) +CONCRETE_ORD_MERGEABLE(Char) +CONCRETE_ORD_MERGEABLE(Int) +CONCRETE_ORD_MERGEABLE(Int8) +CONCRETE_ORD_MERGEABLE(Int16) +CONCRETE_ORD_MERGEABLE(Int32) +CONCRETE_ORD_MERGEABLE(Int64) +CONCRETE_ORD_MERGEABLE(Word) +CONCRETE_ORD_MERGEABLE(Word8) +CONCRETE_ORD_MERGEABLE(Word16) +CONCRETE_ORD_MERGEABLE(Word32) +CONCRETE_ORD_MERGEABLE(Word64) +CONCRETE_ORD_MERGEABLE(Float) +CONCRETE_ORD_MERGEABLE(Double) +CONCRETE_ORD_MERGEABLE(B.ByteString) +CONCRETE_ORD_MERGEABLE(T.Text) +CONCRETE_ORD_MERGEABLE(FPRoundingMode) +CONCRETE_ORD_MERGEABLE(Monoid.All) +CONCRETE_ORD_MERGEABLE(Monoid.Any) +CONCRETE_ORD_MERGEABLE_BV(WordN) +CONCRETE_ORD_MERGEABLE_BV(IntN) +#endif + +instance Mergeable (Proxy a) where + rootStrategy = SimpleStrategy $ \_ t _ -> t + +instance Mergeable1 Proxy where + liftRootStrategy _ = SimpleStrategy $ \_ t _ -> t + {-# INLINE liftRootStrategy #-} + +instance (Integral a, Typeable a, Show a) => Mergeable (Ratio a) where + rootStrategy = + let sub = SimpleStrategy $ \_ t _ -> t + in SortedStrategy id $ const sub + +instance (ValidFP eb sb) => Mergeable (FP eb sb) where + rootStrategy = + let sub = SimpleStrategy $ \_ t _ -> t + in withValidFPProofs @eb @sb + $ SortedStrategy + (\fp -> (bitCastOrCanonical fp :: WordN (eb + sb))) + $ const sub + +instance Mergeable (a =-> b) where + rootStrategy = NoStrategy + +instance Mergeable (a --> b) where + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_SIMPLE(symtype) \ +instance Mergeable symtype where \ + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_FUN(cop, op, consop) \ +instance Mergeable (op sa sb) where \ + rootStrategy = SimpleStrategy symIte + +#if 1 +MERGEABLE_SIMPLE(SymInteger) +MERGEABLE_SIMPLE(SymFPRoundingMode) +MERGEABLE_SIMPLE(SymAlgReal) +MERGEABLE_BV(SymIntN) +MERGEABLE_BV(SymWordN) +MERGEABLE_FUN((=->), (=~>), SymTabularFun) +MERGEABLE_FUN((-->), (-~>), SymGeneralFun) +#endif + +instance (ValidFP eb sb) => Mergeable (SymFP eb sb) where + rootStrategy = SimpleStrategy symIte + +-- function +instance (Mergeable b) => Mergeable (a -> b) where + rootStrategy = case rootStrategy @b of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 ((->) a) where + liftRootStrategy ms = case ms of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE liftRootStrategy #-} + +instance Mergeable2 ((->)) where + liftRootStrategy2 _ ms = case ms of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE liftRootStrategy2 #-} + +-- List + +instance (Mergeable a) => Mergeable [a] where + rootStrategy = case rootStrategy :: MergingStrategy a of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList rootStrategy) $ + \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + ( \case + (SimpleStrategy f, l1, r1) -> f cond l1 r1 + _ -> error "impossible" + ) + <$> zip3 s l r + else NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 [] where + liftRootStrategy (ms :: MergingStrategy a) = case ms of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + ( \case + (SimpleStrategy f, l1, r1) -> f cond l1 r1 + _ -> error "impossible" + ) + <$> zip3 s l r + else NoStrategy + {-# INLINE liftRootStrategy #-} + +instance Mergeable () where + rootStrategy = SimpleStrategy $ \_ t _ -> t + +deriveGADT + [ ''Either, + ''(,) + ] + [''Mergeable, ''Mergeable1, ''Mergeable2] + +deriveGADT + [ ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3] + +deriveGADT + [ ''Maybe, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down, + ''MaybeT, + ''ExceptT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT, + ''StateLazy.StateT, + ''StateStrict.StateT + ] + [''Mergeable, ''Mergeable1] + +deriveGADT + [ ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError, + ''AlgRealPoly, + ''RealPoint, + ''AlgReal + ] + [''Mergeable] + +-- Reader -- separately implemented as we don't need Mergeable s +instance + (Mergeable a, Mergeable1 m) => + Mergeable (ReaderT s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy m)) + ReaderT + runReaderT + {-# INLINE liftRootStrategy #-} + +-- IdentityT +instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (IdentityT m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT + {-# INLINE liftRootStrategy #-} + +-- ContT -- separately implemented as we don't need Mergeable a +instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where + rootStrategy = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where + liftRootStrategy _ = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE liftRootStrategy #-} + +-- RWS -- separately implemented as we don't need Mergeable r +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSLazy.RWST r w s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSLazy.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ + liftRootStrategy3 m rootStrategy rootStrategy + ) + RWSLazy.RWST + (\(RWSLazy.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSStrict.RWST r w s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSStrict.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ + liftRootStrategy3 m rootStrategy rootStrategy + ) + RWSStrict.RWST + (\(RWSStrict.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (Mergeable (l a), Mergeable (r a)) => Mergeable (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (Mergeable1 l, Mergeable1 r) => Mergeable1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (Mergeable (l a), Mergeable (r a)) => Mergeable (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (Mergeable (f (g a))) => Mergeable (Compose f g a) + +instance (Mergeable1 f, Mergeable1 g) => Mergeable1 (Compose f g) where + liftRootStrategy s = + wrapStrategy (liftRootStrategy (liftRootStrategy s)) Compose getCompose + {-# INLINE liftRootStrategy #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (Mergeable a) => Mergeable (Const a b) + +deriving via + (Default1 (Const a)) + instance + (Mergeable a) => Mergeable1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (Mergeable (f a)) => Mergeable (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (Mergeable1 f) => Mergeable1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (Mergeable (f a)) => Mergeable (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (Mergeable1 f) => Mergeable1 (Ap f) + +-- Endo +instance (Mergeable a) => Mergeable (Endo a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance Mergeable1 Endo where + liftRootStrategy strategy = + wrapStrategy (liftRootStrategy strategy) Endo appEndo + +-- Generic +deriving via (Default (U1 p)) instance Mergeable (U1 p) + +deriving via (Default (V1 p)) instance Mergeable (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (Mergeable c) => Mergeable (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (Mergeable (f p)) => Mergeable (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (Mergeable (f p), Mergeable (g p)) => Mergeable ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (Mergeable (f p), Mergeable (g p)) => Mergeable ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (Mergeable p) => Mergeable (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (Mergeable (f p)) => Mergeable (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (Mergeable (f (g p))) => Mergeable ((f :.: g) p) + +-- 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) diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/PPrint.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/PPrint.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + ( K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + V1, + (:.:) (Comp1), + type (:*:), + ) +import GHC.Real (ratioPrec, ratioPrec1) +import GHC.TypeLits (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + U1, + (:+:), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol) +import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint + ( Doc, + PPrint (pformat, pformatList, pformatPrec), + PPrint1 (liftPFormatList, liftPFormatPrec), + PPrint2 (liftPFormatList2, liftPFormatPrec2), + Pretty (pretty), + condEnclose, + pformatListLike, + pformatPrec1, + pformatWithConstructor, + viaShow, + viaShowsPrec, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Internal.Term () +import Grisette.Internal.SymPrim.Prim.Model + ( Model (Model), + SymbolSet (SymbolSet), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( ModelValue, + SomeTypedSymbol (SomeTypedSymbol), + TypedSymbol (unTypedSymbol), + prettyPrintTerm, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +#define FORMAT_SIMPLE(type) \ +instance PPrint type where pformatPrec = viaShowsPrec showsPrec + +#if 1 +FORMAT_SIMPLE(Bool) +FORMAT_SIMPLE(Integer) +FORMAT_SIMPLE(Int) +FORMAT_SIMPLE(Int8) +FORMAT_SIMPLE(Int16) +FORMAT_SIMPLE(Int32) +FORMAT_SIMPLE(Int64) +FORMAT_SIMPLE(Word) +FORMAT_SIMPLE(Word8) +FORMAT_SIMPLE(Word16) +FORMAT_SIMPLE(Word32) +FORMAT_SIMPLE(Word64) +FORMAT_SIMPLE(Float) +FORMAT_SIMPLE(Double) +FORMAT_SIMPLE(FPRoundingMode) +FORMAT_SIMPLE(Monoid.All) +FORMAT_SIMPLE(Monoid.Any) +FORMAT_SIMPLE(Ordering) +FORMAT_SIMPLE(AlgReal) +#endif + +instance PPrint (Proxy a) where + pformatPrec _ _ = "Proxy" + {-# INLINE pformatPrec #-} + +instance PPrint1 Proxy where + liftPFormatPrec _ _ _ _ = "Proxy" + {-# INLINE liftPFormatPrec #-} + +instance (PPrint a) => PPrint (Ratio a) where + pformatPrec p r = + condEnclose (p > ratioPrec) "(" ")" $ + pformatPrec ratioPrec1 (numerator r) + <> "%" + <> pformatPrec ratioPrec1 (denominator r) + +instance PPrint B.ByteString where + pformat = pretty . C.unpack + +instance PPrint T.Text where + pformat = pretty + +instance (KnownNat n, 1 <= n) => PPrint (IntN n) where + pformat = viaShow + +instance (KnownNat n, 1 <= n) => PPrint (WordN n) where + pformat = viaShow + +instance (ValidFP eb sb) => PPrint (FP eb sb) where + pformat = viaShow + +instance (Show a, Show b) => PPrint (a =-> b) where + pformat = viaShow + +instance PPrint (a --> b) where + pformat = viaShow + +-- Prettyprint +#define FORMAT_SYM_SIMPLE(symtype) \ +instance PPrint symtype where \ + pformat (symtype t) = prettyPrintTerm t + +#define FORMAT_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => PPrint (symtype n) where \ + pformat (symtype t) = prettyPrintTerm t + +#define FORMAT_SYM_FUN(op, cons) \ +instance PPrint (sa op sb) where \ + pformat (cons t) = prettyPrintTerm t + +#if 1 +FORMAT_SYM_SIMPLE(SymBool) +FORMAT_SYM_SIMPLE(SymInteger) +FORMAT_SYM_SIMPLE(SymFPRoundingMode) +FORMAT_SYM_SIMPLE(SymAlgReal) +FORMAT_SYM_BV(SymIntN) +FORMAT_SYM_BV(SymWordN) +FORMAT_SYM_FUN(=~>, SymTabularFun) +FORMAT_SYM_FUN(-~>, SymGeneralFun) +#endif + +instance (ValidFP eb sb) => PPrint (SymFP eb sb) where + pformat (SymFP t) = prettyPrintTerm t + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''PPrint] + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''PPrint, ''PPrint1, ''PPrint2] + +deriveGADT + [ ''Maybe, + ''Monoid.Dual, + ''Monoid.First, + ''Monoid.Last, + ''Monoid.Sum, + ''Monoid.Product, + ''Down, + ''MaybeT, + ''ExceptT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''PPrint, ''PPrint1] + +-- Identity +instance (PPrint a) => PPrint (Identity a) where + pformatPrec = pformatPrec1 + +instance PPrint1 Identity where + liftPFormatPrec f _ n (Identity a) = f n a + +-- IdentityT +instance (PPrint1 m, PPrint a) => PPrint (IdentityT m a) where + pformatPrec = pformatPrec1 + +instance (PPrint1 m) => PPrint1 (IdentityT m) where + liftPFormatPrec f l n (IdentityT a) = + pformatWithConstructor n "IdentityT" [liftPFormatPrec f l 11 a] + +-- Product +deriving via + (Default (Product l r a)) + instance + (PPrint (l a), PPrint (r a)) => PPrint (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (PPrint1 l, PPrint1 r) => PPrint1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (PPrint (l a), PPrint (r a)) => PPrint (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (PPrint1 l, PPrint1 r) => PPrint1 (Sum l r) + +-- Compose +instance (PPrint (f (g a))) => PPrint (Compose f g a) where + pformatPrec n (Compose a) = + pformatWithConstructor n "Compose" [pformatPrec 11 a] + +instance (PPrint1 f, PPrint1 g) => PPrint1 (Compose f g) where + liftPFormatPrec f l n (Compose a) = + pformatWithConstructor + n + "Compose" + [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] + +-- Const +deriving via (Default (Const a b)) instance (PPrint a) => PPrint (Const a b) + +deriving via (Default1 (Const a)) instance (PPrint a) => PPrint1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (PPrint (f a)) => PPrint (Alt f a) + +deriving via (Default1 (Alt f)) instance (PPrint1 f) => PPrint1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (PPrint (f a)) => PPrint (Ap f a) + +deriving via (Default1 (Ap f)) instance (PPrint1 f) => PPrint1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance PPrint (U1 p) + +deriving via (Default (V1 p)) instance PPrint (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (PPrint c) => PPrint (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (PPrint (f p)) => PPrint (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (PPrint (f p), PPrint (g p)) => PPrint ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (PPrint (f p), PPrint (g p)) => PPrint ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (PPrint p) => PPrint (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (PPrint (f p)) => PPrint (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (PPrint (f (g p))) => PPrint ((f :.: g) p) + +instance (PPrint a) => PPrint (HS.HashSet a) where + pformatPrec = pformatPrec1 + +instance PPrint1 HS.HashSet where + liftPFormatPrec p l n s = + pformatWithConstructor n "HashSet" [liftPFormatPrec p l 11 $ HS.toList s] + +instance (PPrint k, PPrint v) => PPrint (HM.HashMap k v) where + pformatPrec = pformatPrec1 + +instance (PPrint k) => PPrint1 (HM.HashMap k) where + liftPFormatPrec = liftPFormatPrec2 pformatPrec pformatList + +instance PPrint2 HM.HashMap where + liftPFormatPrec2 pk lk pv lv n s = + pformatWithConstructor + n + "HashMap" + [ liftPFormatPrec + (liftPFormatPrec2 pk lk pv lv) + (liftPFormatList2 pk lk pv lv) + 11 + $ HM.toList s + ] + +instance PPrint Identifier where + pformat = viaShow + +instance PPrint Symbol where + pformat = viaShow + +instance PPrint (TypedSymbol knd t) where + pformat = viaShow + +instance PPrint (SomeTypedSymbol knd) where + pformat = viaShow + +instance PPrint ModelValue where + pformat = viaShow + +instance PPrint Model where + pformatPrec n (Model m) = + pformatWithConstructor n "Model" [bodyFormatted] + where + pformatSymbolWithoutType :: SomeTypedSymbol knd -> Doc ann + pformatSymbolWithoutType (SomeTypedSymbol s) = pformat $ unTypedSymbol s + pformatPair :: (SomeTypedSymbol knd, ModelValue) -> Doc ann + pformatPair (s, v) = pformatSymbolWithoutType s <> " -> " <> pformat v + bodyFormatted = pformatListLike "{" "}" $ pformatPair <$> HM.toList m + +instance PPrint (SymbolSet knd) where + pformatPrec n (SymbolSet s) = + pformatWithConstructor + n + "SymbolSet" + [pformatListLike "{" "}" $ pformat <$> HS.toList s] diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SafeDiv.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SafeDiv.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SafeDiv.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv () where + +import Control.Exception (ArithException (DivideByZero, Overflow)) +import Control.Monad.Except (MonadError (throwError)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==))) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv + ( DivOr (divModOr, divOr, modOr, quotOr, quotRemOr, remOr), + SafeDiv (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem), + ) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm + ), + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) + +concreteDivOrHelper :: + (Integral a) => + (a -> a -> r) -> + r -> + a -> + a -> + r +concreteDivOrHelper f d l r + | r == 0 = d + | otherwise = f l r + +concreteSafeDivHelper :: + (MonadError ArithException m, TryMerge m, Integral a, Mergeable r) => + (a -> a -> r) -> + a -> + a -> + m r +concreteSafeDivHelper f l r + | r == 0 = tryMerge $ throwError DivideByZero + | otherwise = mrgSingle $ f l r + +concreteSignedBoundedDivOrHelper :: + ( Integral a, + Bounded a, + Mergeable r + ) => + (a -> a -> r) -> + r -> + a -> + a -> + r +concreteSignedBoundedDivOrHelper f d l r + | r == 0 = d + | l == minBound && r == -1 = d + | otherwise = f l r + +concreteSignedBoundedSafeDivHelper :: + ( MonadError ArithException m, + TryMerge m, + Integral a, + Bounded a, + Mergeable r + ) => + (a -> a -> r) -> + a -> + a -> + m r +concreteSignedBoundedSafeDivHelper f l r + | r == 0 = tryMerge $ throwError DivideByZero + | l == minBound && r == -1 = tryMerge $ throwError Overflow + | otherwise = mrgSingle $ f l r + +#define QUOTE() ' +#define QID(a) a +#define QRIGHT(a) QID(a)' + +#define QRIGHTT(a) QID(a)' t' +#define QRIGHTU(a) QID(a)' _' + +#define DIVISION_OR_CONCRETE(type) \ +instance DivOr type where \ + divOr = concreteDivOrHelper div; \ + modOr = concreteDivOrHelper mod; \ + divModOr = concreteDivOrHelper divMod; \ + quotOr = concreteDivOrHelper quot; \ + remOr = concreteDivOrHelper rem; \ + quotRemOr = concreteDivOrHelper quotRem + +#define SAFE_DIVISION_CONCRETE(type) \ +instance (MonadError ArithException m, TryMerge m) => \ + SafeDiv ArithException type m where \ + safeDiv = concreteSafeDivHelper div; \ + safeMod = concreteSafeDivHelper mod; \ + safeDivMod = concreteSafeDivHelper divMod; \ + safeQuot = concreteSafeDivHelper quot; \ + safeRem = concreteSafeDivHelper rem; \ + safeQuotRem = concreteSafeDivHelper quotRem + +#define DIVISION_OR_CONCRETE_SIGNED_BOUNDED(type) \ +instance DivOr type where \ + divOr = concreteSignedBoundedDivOrHelper div; \ + modOr = concreteDivOrHelper mod; \ + divModOr = concreteSignedBoundedDivOrHelper divMod; \ + quotOr = concreteSignedBoundedDivOrHelper quot; \ + remOr = concreteDivOrHelper rem; \ + quotRemOr = concreteSignedBoundedDivOrHelper quotRem + +#define SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(type) \ +instance (MonadError ArithException m, TryMerge m) => \ + SafeDiv ArithException type m where \ + safeDiv = concreteSignedBoundedSafeDivHelper div; \ + safeMod = concreteSafeDivHelper mod; \ + safeDivMod = concreteSignedBoundedSafeDivHelper divMod; \ + safeQuot = concreteSignedBoundedSafeDivHelper quot; \ + safeRem = concreteSafeDivHelper rem; \ + safeQuotRem = concreteSignedBoundedSafeDivHelper quotRem + +#if 1 +DIVISION_OR_CONCRETE(Integer) +SAFE_DIVISION_CONCRETE(Integer) +DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int8) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int8) +DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int16) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int16) +DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int32) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int32) +DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int64) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int64) +DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int) +DIVISION_OR_CONCRETE(Word8) +SAFE_DIVISION_CONCRETE(Word8) +DIVISION_OR_CONCRETE(Word16) +SAFE_DIVISION_CONCRETE(Word16) +DIVISION_OR_CONCRETE(Word32) +SAFE_DIVISION_CONCRETE(Word32) +DIVISION_OR_CONCRETE(Word64) +SAFE_DIVISION_CONCRETE(Word64) +DIVISION_OR_CONCRETE(Word) +SAFE_DIVISION_CONCRETE(Word) + + +#endif + +instance (KnownNat n, 1 <= n) => DivOr (IntN n) where + divOr = concreteSignedBoundedDivOrHelper div + modOr = concreteDivOrHelper mod + divModOr = concreteSignedBoundedDivOrHelper divMod + quotOr = concreteSignedBoundedDivOrHelper quot + remOr = concreteDivOrHelper rem + quotRemOr = concreteSignedBoundedDivOrHelper quotRem + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeDiv ArithException (IntN n) m + where + safeDiv = concreteSignedBoundedSafeDivHelper div + safeMod = concreteSafeDivHelper mod + safeDivMod = concreteSignedBoundedSafeDivHelper divMod + safeQuot = concreteSignedBoundedSafeDivHelper quot + safeRem = concreteSafeDivHelper rem + safeQuotRem = concreteSignedBoundedSafeDivHelper quotRem + +instance (KnownNat n, 1 <= n) => DivOr (WordN n) where + divOr = concreteDivOrHelper div + modOr = concreteDivOrHelper mod + divModOr = concreteDivOrHelper divMod + quotOr = concreteDivOrHelper quot + remOr = concreteDivOrHelper rem + quotRemOr = concreteDivOrHelper quotRem + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeDiv ArithException (WordN n) m + where + safeDiv = concreteSafeDivHelper div + safeMod = concreteSafeDivHelper mod + safeDivMod = concreteSafeDivHelper divMod + safeQuot = concreteSafeDivHelper quot + safeRem = concreteSafeDivHelper rem + safeQuotRem = concreteSafeDivHelper quotRem + +#define DIVISION_OR_SYMBOLIC_FUNC(name, type, op) \ +name d (type l) rs@(type r) = \ + symIte (rs .== con 0) d (type $ op l r) + +#define DIVISION_OR_SYMBOLIC_FUNC2(name, type, op1, op2) \ +name (dd, dm) (type l) rs@(type r) = \ + (symIte (rs .== con 0) dd (type $ op1 l r), \ + symIte (rs .== con 0) dm (type $ op2 l r)) + +#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 DivOr SymInteger where + DIVISION_OR_SYMBOLIC_FUNC(divOr, SymInteger, pevalDivIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(modOr, SymInteger, pevalModIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(quotOr, SymInteger, pevalQuotIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(remOr, SymInteger, pevalRemIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC2(divModOr, SymInteger, pevalDivIntegralTerm, pevalModIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC2(quotRemOr, SymInteger, pevalQuotIntegralTerm, pevalRemIntegralTerm) +instance + (MonadUnion m, MonadError ArithException m) => + SafeDiv 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 DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, type, op) \ +name d ls@(type l) rs@(type r) = \ + symIte \ + (rs .== con 0) \ + d \ + (symIte (rs .== con (-1) .&& ls .== con minBound) \ + d \ + (type $ op l r)) \ + +#define DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, type, op1, op2) \ +name (dd, dr) ls@(type l) rs@(type r) = \ + (symIte \ + (rs .== con 0) \ + dd \ + (symIte (rs .== con (-1) .&& ls .== con minBound) \ + dd \ + (type $ op1 l r)), \ + symIte \ + (rs .== con 0) \ + dr \ + (symIte (rs .== con (-1) .&& ls .== con minBound) \ + dr \ + (type $ op2 l r))) \ + +#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 (KnownNat n, 1 <= n) => DivOr (SymIntN n) where + DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(divOr, SymIntN, pevalDivIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(modOr, SymIntN, pevalModIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(quotOr, SymIntN, pevalQuotIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(remOr, SymIntN, pevalRemIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(divModOr, SymIntN, pevalDivIntegralTerm, pevalModIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(quotRemOr, SymIntN, pevalQuotIntegralTerm, pevalRemIntegralTerm) +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeDiv 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 (KnownNat n, 1 <= n) => DivOr (SymWordN n) where + DIVISION_OR_SYMBOLIC_FUNC(divOr, SymWordN, pevalDivIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(modOr, SymWordN, pevalModIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(quotOr, SymWordN, pevalQuotIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC(remOr, SymWordN, pevalRemIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC2(divModOr, SymWordN, pevalDivIntegralTerm, pevalModIntegralTerm) + DIVISION_OR_SYMBOLIC_FUNC2(quotRemOr, SymWordN, pevalQuotIntegralTerm, pevalRemIntegralTerm) +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeDiv 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/Internal/Impl/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SimpleMergeable.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable () where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Cont (ContT (ContT)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Monoid (Alt, Ap, Endo (Endo)) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Proxy (Proxy) +import GHC.Generics + ( K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + ) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving (Default (Default), Default1 (Default1)) +import Grisette.Internal.Core.Control.Exception (AssertionError) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + Mergeable2 (liftRootStrategy2), + Mergeable3 (liftRootStrategy3), + MergingStrategy (SimpleStrategy), + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + SimpleMergeable2 (liftMrgIte2), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + mrgIte1, + ) +import Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge () +import Grisette.Internal.SymPrim.FP (ValidFP) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Identity + +deriveGADT + [ ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2] + +deriveGADT + [ ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Down + ] + [''SimpleMergeable, ''SimpleMergeable1] + +deriveGADT + [''(), ''AssertionError] + [''SimpleMergeable] + +instance SimpleMergeable (Proxy a) where + mrgIte _ l _ = l + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 Proxy where + liftMrgIte _ _ l _ = l + {-# INLINE liftMrgIte #-} + +instance (SimpleMergeable b) => SimpleMergeable (a -> b) where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 ((->) a) where + liftMrgIte ms cond t f v = ms cond (t v) (f v) + {-# INLINE liftMrgIte #-} + +instance SimpleMergeable2 (->) where + liftMrgIte2 _ ms cond t f v = ms cond (t v) (f v) + {-# INLINE liftMrgIte2 #-} + +-- MaybeT +instance (SymBranching m, Mergeable a) => SimpleMergeable (MaybeT m a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance (SymBranching m) => SimpleMergeable1 (MaybeT m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (SymBranching m) => SymBranching (MaybeT m) where + mrgIfWithStrategy strategy cond (MaybeT l) (MaybeT r) = + MaybeT $ mrgIfWithStrategy (liftRootStrategy strategy) cond l r + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (MaybeT l) (MaybeT r) = + MaybeT $ mrgIfPropagatedStrategy cond l r + {-# INLINE mrgIfPropagatedStrategy #-} + +-- ExceptT +instance + (SymBranching m, Mergeable e, Mergeable a) => + SimpleMergeable (ExceptT e m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (SymBranching m, Mergeable e) => + SimpleMergeable1 (ExceptT e m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (SymBranching m, Mergeable e) => + SymBranching (ExceptT e m) + where + mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = + ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (ExceptT t) (ExceptT f) = + ExceptT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +-- StateT +instance + (Mergeable s, Mergeable a, SymBranching m) => + SimpleMergeable (StateLazy.StateT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, SymBranching m) => + SimpleMergeable1 (StateLazy.StateT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, SymBranching m) => + SymBranching (StateLazy.StateT s m) + where + mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) = + StateLazy.StateT $ \v -> + mrgIfWithStrategy + (liftRootStrategy2 s rootStrategy) + cond + (t v) + (f v) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (StateLazy.StateT t) (StateLazy.StateT f) = + StateLazy.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable a, SymBranching m) => + SimpleMergeable (StateStrict.StateT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, SymBranching m) => + SimpleMergeable1 (StateStrict.StateT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, SymBranching m) => + SymBranching (StateStrict.StateT s m) + where + mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) = + StateStrict.StateT $ + \v -> + mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (StateStrict.StateT t) (StateStrict.StateT f) = + StateStrict.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) + {-# INLINE mrgIfPropagatedStrategy #-} + +-- WriterT +instance + (Mergeable s, Mergeable a, SymBranching m, Monoid s) => + SimpleMergeable (WriterLazy.WriterT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, SymBranching m, Monoid s) => + SimpleMergeable1 (WriterLazy.WriterT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, SymBranching m, Monoid s) => + SymBranching (WriterLazy.WriterT s m) + where + mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = + WriterLazy.WriterT $ + mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = + WriterLazy.WriterT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable a, SymBranching m, Monoid s) => + SimpleMergeable (WriterStrict.WriterT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, SymBranching m, Monoid s) => + SimpleMergeable1 (WriterStrict.WriterT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, SymBranching m, Monoid s) => + SymBranching (WriterStrict.WriterT s m) + where + mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = + WriterStrict.WriterT $ + mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy + cond + (WriterStrict.WriterT t) + (WriterStrict.WriterT f) = + WriterStrict.WriterT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +-- ReaderT +instance + (Mergeable a, SymBranching m) => + SimpleMergeable (ReaderT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (SymBranching m) => + SimpleMergeable1 (ReaderT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (SymBranching m) => + SymBranching (ReaderT s m) + where + mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) = + ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (ReaderT t) (ReaderT f) = + ReaderT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) + {-# INLINE mrgIfPropagatedStrategy #-} + +-- IdentityT +instance + (SymBranching m, Mergeable a) => + SimpleMergeable (IdentityT m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance (SymBranching m) => SimpleMergeable1 (IdentityT m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (SymBranching m) => SymBranching (IdentityT m) where + mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = + IdentityT $ mrgIfWithStrategy s cond l r + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (IdentityT l) (IdentityT r) = + IdentityT $ mrgIfPropagatedStrategy cond l r + {-# INLINE mrgIfPropagatedStrategy #-} + +-- ContT +instance (SymBranching m, Mergeable r) => SimpleMergeable (ContT r m a) where + mrgIte cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) + {-# INLINE mrgIte #-} + +instance (SymBranching m, Mergeable r) => SimpleMergeable1 (ContT r m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (SymBranching m, Mergeable r) => SymBranching (ContT r m) where + mrgIfWithStrategy _ cond (ContT l) (ContT r) = + ContT $ \c -> mrgIf cond (l c) (r c) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (ContT l) (ContT r) = + ContT $ \c -> mrgIfPropagatedStrategy cond (l c) (r c) + {-# INLINE mrgIfPropagatedStrategy #-} + +-- RWST +instance + (Mergeable s, Mergeable w, Monoid w, Mergeable a, SymBranching m) => + SimpleMergeable (RWSLazy.RWST r w s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => + SimpleMergeable1 (RWSLazy.RWST r w s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => + SymBranching (RWSLazy.RWST r w s m) + where + mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> + mrgIfWithStrategy + (liftRootStrategy3 ms rootStrategy rootStrategy) + cond + (t r s) + (f r s) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (RWSLazy.RWST t) (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable w, Monoid w, Mergeable a, SymBranching m) => + SimpleMergeable (RWSStrict.RWST r w s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => + SimpleMergeable1 (RWSStrict.RWST r w s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => + SymBranching (RWSStrict.RWST r w s m) + where + mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> + mrgIfWithStrategy + (liftRootStrategy3 ms rootStrategy rootStrategy) + cond + (t r s) + (f r s) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (RWSStrict.RWST t) (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) + {-# INLINE mrgIfPropagatedStrategy #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SimpleMergeable (l a), SimpleMergeable (r a)) => + SimpleMergeable (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SimpleMergeable1 l, SimpleMergeable1 r) => SimpleMergeable1 (Product l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SimpleMergeable (f (g a))) => + SimpleMergeable (Compose f g a) + +instance + (SimpleMergeable1 f, SimpleMergeable1 g) => + SimpleMergeable1 (Compose f g) + where + liftMrgIte m cond (Compose l) (Compose r) = + Compose $ liftMrgIte (liftMrgIte m) cond l r + +-- Const +deriving via + (Default (Const a b)) + instance + (SimpleMergeable a) => SimpleMergeable (Const a b) + +deriving via + (Default1 (Const a)) + instance + (SimpleMergeable a) => SimpleMergeable1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (SimpleMergeable (f a)) => SimpleMergeable (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (SimpleMergeable1 f) => SimpleMergeable1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (SimpleMergeable (f a)) => SimpleMergeable (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (SimpleMergeable1 f) => SimpleMergeable1 (Ap f) + +-- Endo +instance (SimpleMergeable a) => SimpleMergeable (Endo a) where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 Endo where + liftMrgIte m cond (Endo l) (Endo r) = Endo $ liftMrgIte m cond l r + {-# INLINE liftMrgIte #-} + +-- Generic +deriving via (Default (U1 p)) instance SimpleMergeable (U1 p) + +deriving via (Default (V1 p)) instance SimpleMergeable (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SimpleMergeable c) => SimpleMergeable (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SimpleMergeable (f p)) => SimpleMergeable (M1 i c f p) + +deriving via + (Default ((f :*: g) p)) + instance + (SimpleMergeable (f p), SimpleMergeable (g p)) => + SimpleMergeable ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SimpleMergeable p) => SimpleMergeable (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SimpleMergeable (f p)) => SimpleMergeable (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SimpleMergeable (f (g p))) => SimpleMergeable ((f :.: g) p) + +#define SIMPLE_MERGEABLE_SIMPLE(symtype) \ +instance SimpleMergeable symtype where \ + mrgIte = 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 SimpleMergeable (op sa sb) where \ + mrgIte = symIte; \ + {-# INLINE mrgIte #-} + +#if 1 +SIMPLE_MERGEABLE_SIMPLE(SymInteger) +SIMPLE_MERGEABLE_SIMPLE(SymFPRoundingMode) +SIMPLE_MERGEABLE_SIMPLE(SymAlgReal) +SIMPLE_MERGEABLE_BV(SymIntN) +SIMPLE_MERGEABLE_BV(SymWordN) +SIMPLE_MERGEABLE_FUN((=->), (=~>)) +SIMPLE_MERGEABLE_FUN((-->), (-~>)) +#endif + +instance SimpleMergeable (a --> b) where + mrgIte = symIte + {-# INLINE mrgIte #-} + +instance (ValidFP eb sb) => SimpleMergeable (SymFP eb sb) where + mrgIte = symIte + {-# INLINE mrgIte #-} diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/Solver.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/Solver.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.Solver +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.Solver () where + +import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Data.Hashable (Hashable) +import qualified Data.Serialize as Cereal +import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Solver (SolvingFailure) +import Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint () +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +-- $setup +-- >>> import Grisette +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend + +deriveGADT + [''SolvingFailure] + [ ''Show, + ''Eq, + ''PPrint, + ''NFData, + ''Hashable, + ''Serial + ] + +instance Cereal.Serialize SolvingFailure where + put = serialize + get = deserialize + +instance Binary.Binary SolvingFailure where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SubstSym.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SubstSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SubstSym.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import qualified Data.HashSet as HS +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio, denominator, numerator, (%)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import Generics.Deriving.Instances () +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym + ( SubstSym (substSym), + SubstSym1 (liftSubstSym), + SubstSym2, + substSym1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (underlyingTerm), + SymRep (SymType), + someTypedSymbol, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +#define CONCRETE_SUBSTITUTESYM(type) \ +instance SubstSym type where \ + substSym _ _ = id + +#define CONCRETE_SUBSTITUTESYM_BV(type) \ +instance (KnownNat n, 1 <= n) => SubstSym (type n) where \ + substSym _ _ = id + +#if 1 +CONCRETE_SUBSTITUTESYM(Bool) +CONCRETE_SUBSTITUTESYM(Integer) +CONCRETE_SUBSTITUTESYM(Char) +CONCRETE_SUBSTITUTESYM(Int) +CONCRETE_SUBSTITUTESYM(Int8) +CONCRETE_SUBSTITUTESYM(Int16) +CONCRETE_SUBSTITUTESYM(Int32) +CONCRETE_SUBSTITUTESYM(Int64) +CONCRETE_SUBSTITUTESYM(Word) +CONCRETE_SUBSTITUTESYM(Word8) +CONCRETE_SUBSTITUTESYM(Word16) +CONCRETE_SUBSTITUTESYM(Word32) +CONCRETE_SUBSTITUTESYM(Word64) +CONCRETE_SUBSTITUTESYM(Float) +CONCRETE_SUBSTITUTESYM(Double) +CONCRETE_SUBSTITUTESYM(B.ByteString) +CONCRETE_SUBSTITUTESYM(T.Text) +CONCRETE_SUBSTITUTESYM(Monoid.All) +CONCRETE_SUBSTITUTESYM(Monoid.Any) +CONCRETE_SUBSTITUTESYM(Ordering) +CONCRETE_SUBSTITUTESYM_BV(WordN) +CONCRETE_SUBSTITUTESYM_BV(IntN) +CONCRETE_SUBSTITUTESYM(FPRoundingMode) +CONCRETE_SUBSTITUTESYM(AlgReal) +#endif + +instance SubstSym (Proxy a) where + substSym _ _ = id + {-# INLINE substSym #-} + +instance SubstSym1 Proxy where + liftSubstSym _ _ _ = id + {-# INLINE liftSubstSym #-} + +instance (Integral a, SubstSym a) => SubstSym (Ratio a) where + substSym sym val a = + substSym sym val (numerator a) % substSym sym val (denominator a) + {-# INLINE substSym #-} + +instance (ValidFP eb sb) => SubstSym (FP eb sb) where + substSym _ _ = id + +#define SUBSTITUTE_SYM_SIMPLE(symtype) \ +instance SubstSym symtype where \ + substSym sym v (symtype t) = \ + symtype $ substTerm sym (underlyingTerm v) HS.empty t + +#define SUBSTITUTE_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SubstSym (symtype n) where \ + substSym sym v (symtype t) = \ + symtype $ substTerm sym (underlyingTerm v) HS.empty t + +#define SUBSTITUTE_SYM_FUN(op, cons) \ +instance SubstSym (op sa sb) where \ + substSym sym v (cons t) = \ + cons $ substTerm sym (underlyingTerm v) HS.empty t + +#if 1 +SUBSTITUTE_SYM_SIMPLE(SymBool) +SUBSTITUTE_SYM_SIMPLE(SymInteger) +SUBSTITUTE_SYM_SIMPLE(SymAlgReal) +SUBSTITUTE_SYM_BV(SymIntN) +SUBSTITUTE_SYM_BV(SymWordN) +SUBSTITUTE_SYM_FUN((=~>), SymTabularFun) +SUBSTITUTE_SYM_FUN((-~>), SymGeneralFun) +SUBSTITUTE_SYM_SIMPLE(SymFPRoundingMode) +#endif + +instance (ValidFP eb sb) => SubstSym (SymFP eb sb) where + substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) HS.empty t + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''SubstSym] + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''SubstSym, ''SubstSym1, ''SubstSym2] + +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''Monoid.Dual, + ''Monoid.First, + ''Monoid.Last, + ''Monoid.Sum, + ''Monoid.Product, + ''Down, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''SubstSym, ''SubstSym1] + +-- IdentityT +instance + (SubstSym1 m, SubstSym a) => + SubstSym (IdentityT m a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance (SubstSym1 m) => SubstSym1 (IdentityT m) where + liftSubstSym f sym val (IdentityT a) = + IdentityT $ liftSubstSym f sym val a + {-# INLINE liftSubstSym #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SubstSym (l a), SubstSym (r a)) => SubstSym (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SubstSym1 l, SubstSym1 r) => SubstSym1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (SubstSym (l a), SubstSym (r a)) => SubstSym (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (SubstSym1 l, SubstSym1 r) => SubstSym1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SubstSym (f (g a))) => SubstSym (Compose f g a) + +instance + (SubstSym1 f, SubstSym1 g) => + SubstSym1 (Compose f g) + where + liftSubstSym f sym val (Compose x) = + Compose $ liftSubstSym (liftSubstSym f) sym val x + {-# INLINE liftSubstSym #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (SubstSym a) => SubstSym (Const a b) + +deriving via + (Default1 (Const a)) + instance + (SubstSym a) => SubstSym1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (SubstSym (f a)) => SubstSym (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (SubstSym1 f) => SubstSym1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (SubstSym (f a)) => SubstSym (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (SubstSym1 f) => SubstSym1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance SubstSym (U1 p) + +deriving via (Default (V1 p)) instance SubstSym (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SubstSym c) => SubstSym (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SubstSym (f p)) => SubstSym (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (SubstSym (f p), SubstSym (g p)) => SubstSym ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (SubstSym (f p), SubstSym (g p)) => SubstSym ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SubstSym p) => SubstSym (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SubstSym (f p)) => SubstSym (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SubstSym (f (g p))) => SubstSym ((f :.: g) p) + +instance (SubstSym a, SubstSym b) => SubstSym (a =-> b) where + substSym sym val (TabularFun f d) = + TabularFun (substSym sym val f) (substSym sym val d) + {-# INLINE substSym #-} + +instance (SubstSym (SymType b)) => SubstSym (a --> b) where + substSym sym val (GeneralFun s t) = + GeneralFun s $ + substTerm sym (underlyingTerm val) (HS.singleton $ someTypedSymbol s) t + {-# INLINE substSym #-} diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymEq.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymEq.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=symeq #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( SymEq (symDistinct, (./=), (.==)), + SymEq1 (liftSymEq), + SymEq2, + symEq1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( SupportedPrim (pevalDistinctTerm), + pevalEqTerm, + underlyingTerm, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +#define CONCRETE_SEQ(type) \ +instance SymEq type where \ + l .== r = con $ l == r; \ + {-# INLINE (.==) #-} + +#define CONCRETE_SEQ_BV(type) \ +instance (KnownNat n, 1 <= n) => SymEq (type n) where \ + l .== r = con $ l == r; \ + {-# INLINE (.==) #-} + +#if 1 +CONCRETE_SEQ(Bool) +CONCRETE_SEQ(Integer) +CONCRETE_SEQ(Char) +CONCRETE_SEQ(Int) +CONCRETE_SEQ(Int8) +CONCRETE_SEQ(Int16) +CONCRETE_SEQ(Int32) +CONCRETE_SEQ(Int64) +CONCRETE_SEQ(Word) +CONCRETE_SEQ(Word8) +CONCRETE_SEQ(Word16) +CONCRETE_SEQ(Word32) +CONCRETE_SEQ(Word64) +CONCRETE_SEQ(Float) +CONCRETE_SEQ(Double) +CONCRETE_SEQ(B.ByteString) +CONCRETE_SEQ(T.Text) +CONCRETE_SEQ(FPRoundingMode) +CONCRETE_SEQ(Monoid.All) +CONCRETE_SEQ(Monoid.Any) +CONCRETE_SEQ(Ordering) +CONCRETE_SEQ_BV(WordN) +CONCRETE_SEQ_BV(IntN) +CONCRETE_SEQ(AlgReal) +#endif + +instance SymEq (Proxy a) where + _ .== _ = con True + {-# INLINE (.==) #-} + +instance SymEq1 Proxy where + liftSymEq _ _ _ = con True + {-# INLINE liftSymEq #-} + +instance (SymEq a) => SymEq (Ratio a) where + a .== b = numerator a .== numerator b .&& denominator a .== denominator b + {-# INLINE (.==) #-} + +instance (ValidFP eb sb) => SymEq (FP eb sb) where + l .== r = con $ l == r + {-# INLINE (.==) #-} + +-- Symbolic types +#define SEQ_SIMPLE(symtype) \ +instance SymEq symtype where \ + (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ + {-# INLINE (.==) #-}; \ + l ./= r = symDistinct [l, r]; \ + {-# INLINE (./=) #-}; \ + symDistinct [] = con True; \ + symDistinct [_] = con True; \ + symDistinct (l:ls) = SymBool $ \ + pevalDistinctTerm (underlyingTerm l :| (underlyingTerm <$> ls)) + +#define SEQ_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SymEq (symtype n) where \ + (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ + {-# INLINE (.==) #-}; \ + l ./= r = symDistinct [l, r]; \ + {-# INLINE (./=) #-}; \ + symDistinct [] = con True; \ + symDistinct [_] = con True; \ + symDistinct (l:ls) = SymBool $ \ + pevalDistinctTerm (underlyingTerm l :| (underlyingTerm <$> ls)) + +#if 1 +SEQ_SIMPLE(SymBool) +SEQ_SIMPLE(SymInteger) +SEQ_SIMPLE(SymFPRoundingMode) +SEQ_SIMPLE(SymAlgReal) +SEQ_BV(SymIntN) +SEQ_BV(SymWordN) +#endif + +instance (ValidFP eb sb) => SymEq (SymFP eb sb) where + (SymFP l) .== (SymFP r) = SymBool $ pevalEqTerm l r + {-# INLINE (.==) #-} + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''SymEq] + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''SymEq, ''SymEq1, ''SymEq2] + +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''Monoid.Dual, + ''Monoid.First, + ''Monoid.Last, + ''Monoid.Sum, + ''Monoid.Product, + ''Down, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''SymEq, ''SymEq1] + +-- IdentityT +instance (SymEq1 m, SymEq a) => SymEq (IdentityT m a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (SymEq1 m) => SymEq1 (IdentityT m) where + liftSymEq f (IdentityT l) (IdentityT r) = liftSymEq f l r + {-# INLINE liftSymEq #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SymEq (l a), SymEq (r a)) => SymEq (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SymEq1 l, SymEq1 r) => SymEq1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (SymEq (l a), SymEq (r a)) => SymEq (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (SymEq1 l, SymEq1 r) => SymEq1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SymEq (f (g a))) => SymEq (Compose f g a) + +instance (SymEq1 f, SymEq1 g) => SymEq1 (Compose f g) where + liftSymEq f (Compose l) (Compose r) = liftSymEq (liftSymEq f) l r + +-- Const +deriving via (Default (Const a b)) instance (SymEq a) => SymEq (Const a b) + +deriving via (Default1 (Const a)) instance (SymEq a) => SymEq1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (SymEq (f a)) => SymEq (Alt f a) + +deriving via (Default1 (Alt f)) instance (SymEq1 f) => SymEq1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (SymEq (f a)) => SymEq (Ap f a) + +deriving via (Default1 (Ap f)) instance (SymEq1 f) => SymEq1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance SymEq (U1 p) + +deriving via (Default (V1 p)) instance SymEq (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SymEq c) => SymEq (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SymEq (f p)) => SymEq (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (SymEq (f p), SymEq (g p)) => SymEq ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (SymEq (f p), SymEq (g p)) => SymEq ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SymEq p) => SymEq (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SymEq (f p)) => SymEq (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SymEq (f (g p))) => SymEq ((f :.: g) p) diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymOrd.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymOrd.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down (Down)) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq + ( SymEq ((.==)), + ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( mrgSingle, + tryMerge, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + ( SymOrd (symCompare, (.<), (.<=), (.>), (.>=)), + SymOrd1 (liftSymCompare), + SymOrd2, + symCompare1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalOrdTerm + ( pevalLeOrdTerm, + pevalLtOrdTerm + ), + pevalGeOrdTerm, + pevalGtOrdTerm, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +#define CONCRETE_SORD(type) \ +instance SymOrd type where \ + l .<= r = con $ l <= r; \ + l .< r = con $ l < r; \ + l .>= r = con $ l >= r; \ + l .> r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r; \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +#define CONCRETE_SORD_BV(type) \ +instance (KnownNat n, 1 <= n) => SymOrd (type n) where \ + l .<= r = con $ l <= r; \ + l .< r = con $ l < r; \ + l .>= r = con $ l >= r; \ + l .> r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r; \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +#if 1 +CONCRETE_SORD(Bool) +CONCRETE_SORD(Integer) +CONCRETE_SORD(Char) +CONCRETE_SORD(Int) +CONCRETE_SORD(Int8) +CONCRETE_SORD(Int16) +CONCRETE_SORD(Int32) +CONCRETE_SORD(Int64) +CONCRETE_SORD(Word) +CONCRETE_SORD(Word8) +CONCRETE_SORD(Word16) +CONCRETE_SORD(Word32) +CONCRETE_SORD(Word64) +CONCRETE_SORD(Float) +CONCRETE_SORD(Double) +CONCRETE_SORD(B.ByteString) +CONCRETE_SORD(T.Text) +CONCRETE_SORD(FPRoundingMode) +CONCRETE_SORD(Monoid.All) +CONCRETE_SORD(Monoid.Any) +CONCRETE_SORD(Ordering) +CONCRETE_SORD_BV(WordN) +CONCRETE_SORD_BV(IntN) +CONCRETE_SORD(AlgReal) +#endif + +instance SymOrd (Proxy a) where + _ .<= _ = con True + {-# INLINE (.<=) #-} + _ .< _ = con False + {-# INLINE (.<) #-} + _ .>= _ = con True + {-# INLINE (.>=) #-} + _ .> _ = con False + {-# INLINE (.>) #-} + symCompare _ _ = mrgSingle EQ + {-# INLINE symCompare #-} + +instance SymOrd1 Proxy where + liftSymCompare _ _ _ = mrgSingle EQ + {-# INLINE liftSymCompare #-} + +instance (SymOrd a, Integral a) => SymOrd (Ratio a) where + a .<= b = numerator a * denominator b .<= numerator b * denominator a + {-# INLINE (.<=) #-} + a .< b = numerator a * denominator b .< numerator b * denominator a + {-# INLINE (.<) #-} + +instance (ValidFP eb sb) => SymOrd (FP eb sb) where + l .<= r = con $ l <= r + {-# INLINE (.<=) #-} + l .< r = con $ l < r + {-# INLINE (.<) #-} + l .>= r = con $ l >= r + {-# INLINE (.>=) #-} + l .> r = con $ l > r + {-# INLINE (.>) #-} + +-- SymOrd +#define SORD_SIMPLE(symtype) \ +instance SymOrd symtype where \ + (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ + (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ + (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ + (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ + a `symCompare` b = mrgIf \ + (a .< b) \ + (mrgSingle LT) \ + (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)); \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +#define SORD_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SymOrd (symtype n) where \ + (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ + (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ + (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ + (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ + a `symCompare` b = mrgIf \ + (a .< b) \ + (mrgSingle LT) \ + (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)); \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +instance (ValidFP eb sb) => SymOrd (SymFP eb sb) where + (SymFP a) .<= (SymFP b) = SymBool $ pevalLeOrdTerm a b + {-# INLINE (.<=) #-} + (SymFP a) .< (SymFP b) = SymBool $ pevalLtOrdTerm a b + {-# INLINE (.<) #-} + (SymFP a) .>= (SymFP b) = SymBool $ pevalGeOrdTerm a b + {-# INLINE (.>=) #-} + (SymFP a) .> (SymFP b) = SymBool $ pevalGtOrdTerm a b + {-# INLINE (.>) #-} + +instance SymOrd SymBool where + l .<= r = symNot l .|| r + {-# INLINE (.<=) #-} + l .< r = symNot l .&& r + {-# INLINE (.<) #-} + l .>= r = l .|| symNot r + {-# INLINE (.>=) #-} + l .> r = l .&& symNot r + {-# INLINE (.>) #-} + symCompare l r = + mrgIf + (symNot l .&& r) + (mrgSingle LT) + (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) + {-# INLINE symCompare #-} + +#if 1 +SORD_SIMPLE(SymInteger) +SORD_SIMPLE(SymAlgReal) +SORD_SIMPLE(SymFPRoundingMode) +SORD_BV(SymIntN) +SORD_BV(SymWordN) +#endif + +-- Union +instance (SymOrd a) => SymOrd (Union a) where + x .<= y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .<= y1 + x .< y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .< y1 + x .>= y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .>= y1 + x .> y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .> y1 + x `symCompare` y = tryMerge $ do + x1 <- x + y1 <- y + x1 `symCompare` y1 + +instance SymOrd1 Union where + liftSymCompare f x y = tryMerge $ do + x1 <- x + y1 <- y + f x1 y1 + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''SymOrd] + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''SymOrd, ''SymOrd1, ''SymOrd2] + +deriveGADT + [ ''Maybe, + ''Identity, + ''Monoid.Dual, + ''Monoid.First, + ''Monoid.Last, + ''Monoid.Sum, + ''Monoid.Product, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''SymOrd, ''SymOrd1] + +symCompareSingleList :: (SymOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool +symCompareSingleList isLess isStrict = go + where + go [] [] = con (not isStrict) + go (x : xs) (y : ys) = + (if isLess then x .< y else x .> y) .|| (x .== y .&& go xs ys) + go [] _ = if isLess then con True else con False + go _ [] = if isLess then con False else con True + +symLiftCompareList :: + (a -> b -> Union Ordering) -> [a] -> [b] -> Union Ordering +symLiftCompareList _ [] [] = mrgSingle EQ +symLiftCompareList f (x : xs) (y : ys) = do + oxy <- f x y + case oxy of + LT -> mrgSingle LT + EQ -> symLiftCompareList f xs ys + GT -> mrgSingle GT +symLiftCompareList _ [] _ = mrgSingle LT +symLiftCompareList _ _ [] = mrgSingle GT + +-- [] +instance (SymOrd a) => SymOrd [a] where + {-# INLINE (.<=) #-} + {-# INLINE (.<) #-} + {-# INLINE symCompare #-} + {-# INLINE (.>=) #-} + {-# INLINE (.>) #-} + (.<=) = symCompareSingleList True False + (.<) = symCompareSingleList True True + (.>=) = symCompareSingleList False False + (.>) = symCompareSingleList False True + symCompare = symLiftCompareList symCompare + +instance SymOrd1 [] where + liftSymCompare = symLiftCompareList + {-# INLINE liftSymCompare #-} + +-- IdentityT +instance (SymOrd1 m, SymOrd a) => SymOrd (IdentityT m a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance (SymOrd1 m) => SymOrd1 (IdentityT m) where + liftSymCompare f (IdentityT l) (IdentityT r) = liftSymCompare f l r + {-# INLINE liftSymCompare #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SymOrd (l a), SymOrd (r a)) => SymOrd (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SymOrd1 l, SymOrd1 r) => SymOrd1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (SymOrd (l a), SymOrd (r a)) => SymOrd (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (SymOrd1 l, SymOrd1 r) => SymOrd1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SymOrd (f (g a))) => SymOrd (Compose f g a) + +instance (SymOrd1 f, SymOrd1 g) => SymOrd1 (Compose f g) where + liftSymCompare f (Compose l) (Compose r) = + liftSymCompare (liftSymCompare f) l r + +-- Const +deriving via (Default (Const a b)) instance (SymOrd a) => SymOrd (Const a b) + +deriving via (Default1 (Const a)) instance (SymOrd a) => SymOrd1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (SymOrd (f a)) => SymOrd (Alt f a) + +deriving via (Default1 (Alt f)) instance (SymOrd1 f) => SymOrd1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (SymOrd (f a)) => SymOrd (Ap f a) + +deriving via (Default1 (Ap f)) instance (SymOrd1 f) => SymOrd1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance SymOrd (U1 p) + +deriving via (Default (V1 p)) instance SymOrd (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SymOrd c) => SymOrd (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SymOrd (f p)) => SymOrd (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (SymOrd (f p), SymOrd (g p)) => SymOrd ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (SymOrd (f p), SymOrd (g p)) => SymOrd ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SymOrd p) => SymOrd (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SymOrd (f p)) => SymOrd (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SymOrd (f (g p))) => SymOrd ((f :.: g) p) + +-- Down +instance (SymOrd a) => SymOrd (Down a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance SymOrd1 Down where + liftSymCompare comp (Down l) (Down r) = do + res <- comp l r + case res of + LT -> mrgSingle GT + EQ -> mrgSingle EQ + GT -> mrgSingle LT + {-# INLINE liftSymCompare #-} diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToCon.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToCon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToCon.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon () where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity, runIdentity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator, (%)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + ( K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving (Default (Default), Default1 (Default1)) +import Generics.Deriving.Instances () +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.BitCast (bitCastOrCanonical) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (conView), + pattern Con, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon + ( ToCon (toCon), + ToCon1 (liftToCon), + ToCon2, + toCon1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal (AlgExactRational)) +import Grisette.Internal.SymPrim.BV + ( IntN (IntN), + WordN (WordN), + ) +import Grisette.Internal.SymPrim.FP + ( FP, + FP32, + FP64, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) +import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP + ( SymFP, + SymFP32, + SymFP64, + SymFPRoundingMode, + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +#define CONCRETE_TOCON(type) \ +instance ToCon type type where \ + toCon = Just + +#define CONCRETE_TOCON_BV(type) \ +instance (KnownNat n, 1 <= n) => ToCon (type n) (type n) where \ + toCon = Just + +#if 1 +CONCRETE_TOCON(Bool) +CONCRETE_TOCON(Integer) +CONCRETE_TOCON(Char) +CONCRETE_TOCON(Int) +CONCRETE_TOCON(Int8) +CONCRETE_TOCON(Int16) +CONCRETE_TOCON(Int32) +CONCRETE_TOCON(Int64) +CONCRETE_TOCON(Word) +CONCRETE_TOCON(Word8) +CONCRETE_TOCON(Word16) +CONCRETE_TOCON(Word32) +CONCRETE_TOCON(Word64) +CONCRETE_TOCON(Float) +CONCRETE_TOCON(Double) +CONCRETE_TOCON(B.ByteString) +CONCRETE_TOCON(T.Text) +CONCRETE_TOCON_BV(WordN) +CONCRETE_TOCON_BV(IntN) +CONCRETE_TOCON(FPRoundingMode) +CONCRETE_TOCON(Monoid.All) +CONCRETE_TOCON(Monoid.Any) +CONCRETE_TOCON(Ordering) +#endif + +instance (ValidFP eb sb) => ToCon (FP eb sb) (FP eb sb) where + toCon = Just + +instance ToCon (a =-> b) (a =-> b) where + toCon = Just + +instance ToCon (a --> b) (a --> b) where + toCon = Just + +#define TO_CON_SYMID_SIMPLE(symtype) \ +instance ToCon symtype symtype where \ + toCon = Just + +#define TO_CON_SYMID_BV(symtype) \ +instance ToCon (symtype n) (symtype n) where \ + toCon = Just + +#define TO_CON_SYMID_FUN(op) \ +instance ToCon (a op b) (a op b) where \ + toCon = Just + +#if 1 +TO_CON_SYMID_SIMPLE(SymBool) +TO_CON_SYMID_SIMPLE(SymInteger) +TO_CON_SYMID_SIMPLE(SymAlgReal) +TO_CON_SYMID_BV(SymIntN) +TO_CON_SYMID_BV(SymWordN) +TO_CON_SYMID_FUN(=~>) +TO_CON_SYMID_FUN(-~>) +TO_CON_SYMID_SIMPLE(SymFPRoundingMode) +#endif + +instance (ValidFP eb sb) => ToCon (SymFP eb sb) (SymFP eb sb) where + toCon = Just + +#define TO_CON_FROMSYM_SIMPLE(contype, symtype) \ +instance ToCon symtype contype where \ + toCon = conView + +#define TO_CON_FROMSYM_BV(contype, symtype) \ +instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \ + toCon = conView + +#define TO_CON_FROMSYM_FUN(conop, symop, consop) \ +instance (LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \ + toCon a@(consop _) = conView a + +#if 1 +-- TO_CON_FROMSYM_SIMPLE(Bool, SymBool) +TO_CON_FROMSYM_SIMPLE(Integer, SymInteger) +TO_CON_FROMSYM_SIMPLE(AlgReal, SymAlgReal) +TO_CON_FROMSYM_BV(IntN, SymIntN) +TO_CON_FROMSYM_BV(WordN, SymWordN) +TO_CON_FROMSYM_FUN((=->), (=~>), SymTabularFun) +TO_CON_FROMSYM_FUN((-->), (-~>), SymGeneralFun) +TO_CON_FROMSYM_SIMPLE(FPRoundingMode, SymFPRoundingMode) +#endif + +instance (ValidFP eb sb) => ToCon (SymFP eb sb) (FP eb sb) where + toCon = conView + +#define TOCON_MACHINE_INTEGER(sbvw, bvw, n, int) \ +instance ToCon (sbvw n) int where \ + toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \ + toCon _ = Nothing + +#if 1 +TOCON_MACHINE_INTEGER(SymIntN, IntN, 8, Int8) +TOCON_MACHINE_INTEGER(SymIntN, IntN, 16, Int16) +TOCON_MACHINE_INTEGER(SymIntN, IntN, 32, Int32) +TOCON_MACHINE_INTEGER(SymIntN, IntN, 64, Int64) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 8, Word8) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 16, Word16) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 32, Word32) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 64, Word64) +TOCON_MACHINE_INTEGER(SymIntN, IntN, $intBitwidthQ, Int) +TOCON_MACHINE_INTEGER(SymWordN, WordN, $intBitwidthQ, Word) +#endif + +instance ToCon SymFP32 Float where + toCon (Con (fp :: FP32)) = Just $ bitCastOrCanonical fp + toCon _ = Nothing + +instance ToCon SymFP64 Double where + toCon (Con (fp :: FP64)) = Just $ bitCastOrCanonical fp + toCon _ = Nothing + +instance (ToCon a b, Integral b) => ToCon (Ratio a) (Ratio b) where + toCon r = do + n <- toCon (numerator r) + d <- toCon (denominator r) + return $ n % d + +instance ToCon SymAlgReal Rational where + toCon (Con (x :: AlgReal)) = + case x of + AlgExactRational r -> Just r + _ -> Nothing + toCon _ = Nothing + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''ToCon, ''ToCon1, ''ToCon2] + +deriveGADT + [ ''[], + ''Maybe, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''ToCon, ''ToCon1] + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''ToCon] + +-- IdentityT +instance + (ToCon1 m m1, ToCon a b) => + ToCon (IdentityT m a) (IdentityT m1 b) + where + toCon = toCon1 + {-# INLINE toCon #-} + +instance + (ToCon1 m m1) => + ToCon1 (IdentityT m) (IdentityT m1) + where + liftToCon f (IdentityT a) = IdentityT <$> liftToCon f a + {-# INLINE liftToCon #-} + +-- Identity +instance {-# INCOHERENT #-} (ToCon a b) => ToCon (Identity a) (Identity b) where + toCon = toCon1 + +instance {-# INCOHERENT #-} (ToCon a b) => ToCon (Identity a) b where + toCon = toCon . runIdentity + +instance {-# INCOHERENT #-} (ToCon a b) => ToCon a (Identity b) where + toCon = fmap Identity . toCon + +instance ToCon1 Identity Identity where + liftToCon f (Identity a) = Identity <$> f a + +-- Special +instance + (ToCon (m1 (Either e1 a)) (Either e2 b)) => + ToCon (ExceptT e1 m1 a) (Either e2 b) + where + toCon (ExceptT v) = toCon v + +-- Product +deriving via + (Default (Product l r a)) + instance + (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) => + ToCon (Product l0 r0 a0) (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Product l0 r0) (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) => + ToCon (Sum l0 r0 a0) (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Sum l0 r0) (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (ToCon (f0 (g0 a0)) (f (g a))) => ToCon (Compose f0 g0 a0) (Compose f g a) + +instance + (ToCon1 f0 f, ToCon1 g0 g) => + ToCon1 (Compose f0 g0) (Compose f g) + where + liftToCon f (Compose a) = Compose <$> liftToCon (liftToCon f) a + {-# INLINE liftToCon #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (ToCon a0 a) => ToCon (Const a0 b0) (Const a b) + +deriving via + (Default1 (Const a)) + instance + (ToCon a0 a) => ToCon1 (Const a0) (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (ToCon (f0 a0) (f a)) => ToCon (Alt f0 a0) (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (ToCon1 f0 f) => ToCon1 (Alt f0) (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (ToCon (f0 a0) (f a)) => ToCon (Ap f0 a0) (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (ToCon1 f0 f) => ToCon1 (Ap f0) (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance ToCon (U1 p0) (U1 p) + +deriving via (Default (V1 p)) instance ToCon (V1 p0) (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (ToCon c0 c) => ToCon (K1 i0 c0 p0) (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (ToCon (f0 p0) (f p)) => ToCon (M1 i0 c0 f0 p0) (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (ToCon (f0 p0) (f p), ToCon (g0 p0) (g p)) => + ToCon ((f0 :+: g0) p0) ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (ToCon (f0 p0) (f p), ToCon (g0 p0) (g p)) => + ToCon ((f0 :*: g0) p0) ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (ToCon p0 p) => ToCon (Par1 p0) (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (ToCon (f0 p0) (f p)) => ToCon (Rec1 f0 p0) (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (ToCon (f0 (g0 p0)) (f (g p))) => ToCon ((f0 :.: g0) p0) ((f :.: g) p) diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToSym.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToSym.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym () where + +import Control.Monad.Identity + ( Identity (Identity, runIdentity), + IdentityT (IdentityT), + ) +import Control.Monad.Reader (ReaderT (ReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator, (%)) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:), + type (:+:), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast)) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym + ( ToSym (toSym), + ToSym1 (liftToSym), + ToSym2 (liftToSym2), + toSym1, + ) +import Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable () +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedNonFuncPrim, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP + ( SymFP, + SymFP32, + SymFP64, + SymFPRoundingMode, + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +-- $setup +-- >>> import Grisette.SymPrim + +#define CONCRETE_TOSYM(type) \ +instance ToSym type type where \ + toSym = id + +#define CONCRETE_TOSYM_BV(type) \ +instance (KnownNat n, 1 <= n) => ToSym (type n) (type n) where \ + toSym = id + +#if 1 +CONCRETE_TOSYM(Bool) +CONCRETE_TOSYM(Integer) +CONCRETE_TOSYM(Char) +CONCRETE_TOSYM(Int) +CONCRETE_TOSYM(Int8) +CONCRETE_TOSYM(Int16) +CONCRETE_TOSYM(Int32) +CONCRETE_TOSYM(Int64) +CONCRETE_TOSYM(Word) +CONCRETE_TOSYM(Word8) +CONCRETE_TOSYM(Word16) +CONCRETE_TOSYM(Word32) +CONCRETE_TOSYM(Word64) +CONCRETE_TOSYM(Float) +CONCRETE_TOSYM(Double) +CONCRETE_TOSYM(B.ByteString) +CONCRETE_TOSYM(T.Text) +CONCRETE_TOSYM(FPRoundingMode) +CONCRETE_TOSYM_BV(IntN) +CONCRETE_TOSYM_BV(WordN) +CONCRETE_TOSYM(Monoid.All) +CONCRETE_TOSYM(Monoid.Any) +CONCRETE_TOSYM(Ordering) +#endif + +instance (ValidFP eb sb) => ToSym (FP eb sb) (FP eb sb) where + toSym = id + +instance ToSym (a =-> b) (a =-> b) where + toSym = id + +instance ToSym (a --> b) (a --> b) where + toSym = id + +#define TO_SYM_SYMID_SIMPLE(symtype) \ +instance ToSym symtype symtype where \ + toSym = id + +#define TO_SYM_SYMID_BV(symtype) \ +instance (KnownNat n, 1 <= n) => ToSym (symtype n) (symtype n) where \ + toSym = id + +#define TO_SYM_SYMID_FUN(cop, op) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + ToSym (op sa sb) (op sa sb) where \ + toSym = id + +#if 1 +TO_SYM_SYMID_SIMPLE(SymBool) +TO_SYM_SYMID_SIMPLE(SymInteger) +TO_SYM_SYMID_SIMPLE(SymAlgReal) +TO_SYM_SYMID_BV(SymIntN) +TO_SYM_SYMID_BV(SymWordN) +TO_SYM_SYMID_FUN((=->), (=~>)) +TO_SYM_SYMID_FUN((-->), (-~>)) +TO_SYM_SYMID_SIMPLE(SymFPRoundingMode) +#endif + +instance (ValidFP eb sb) => ToSym (SymFP eb sb) (SymFP eb sb) where + toSym = id + +#define TO_SYM_FROMCON_SIMPLE(contype, symtype) \ +instance ToSym contype symtype where \ + toSym = con + +#define TO_SYM_FROMCON_BV(contype, symtype) \ +instance (KnownNat n, 1 <= n) => ToSym (contype n) (symtype n) where \ + toSym = con + +#define TO_SYM_FROMCON_FUN(conop, symop) \ +instance (SupportedPrim (conop ca cb), SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb) => \ + ToSym (conop ca cb) (symop sa sb) where \ + toSym = con + +#if 1 +TO_SYM_FROMCON_SIMPLE(Bool, SymBool) +TO_SYM_FROMCON_SIMPLE(Integer, SymInteger) +TO_SYM_FROMCON_SIMPLE(AlgReal, SymAlgReal) +TO_SYM_FROMCON_BV(IntN, SymIntN) +TO_SYM_FROMCON_BV(WordN, SymWordN) +TO_SYM_FROMCON_FUN((=->), (=~>)) +TO_SYM_FROMCON_FUN((-->), (-~>)) +TO_SYM_FROMCON_SIMPLE(FPRoundingMode, SymFPRoundingMode) +#endif + +instance (ValidFP eb sb) => ToSym (FP eb sb) (SymFP eb sb) where + toSym = con + +#define TOSYM_MACHINE_INTEGER(int, bv) \ +instance ToSym int (bv) where \ + toSym = fromIntegral + +#if 1 +TOSYM_MACHINE_INTEGER(Int8, SymIntN 8) +TOSYM_MACHINE_INTEGER(Int16, SymIntN 16) +TOSYM_MACHINE_INTEGER(Int32, SymIntN 32) +TOSYM_MACHINE_INTEGER(Int64, SymIntN 64) +TOSYM_MACHINE_INTEGER(Word8, SymWordN 8) +TOSYM_MACHINE_INTEGER(Word16, SymWordN 16) +TOSYM_MACHINE_INTEGER(Word32, SymWordN 32) +TOSYM_MACHINE_INTEGER(Word64, SymWordN 64) +TOSYM_MACHINE_INTEGER(Int, SymIntN $intBitwidthQ) +TOSYM_MACHINE_INTEGER(Word, SymWordN $intBitwidthQ) +#endif + +instance ToSym Float SymFP32 where + toSym = con . bitCast + {-# INLINE toSym #-} + +instance ToSym Double SymFP64 where + toSym = con . bitCast + {-# INLINE toSym #-} + +instance + (Integral b, Typeable b, Show b, ToSym a b) => + ToSym (Ratio a) (Ratio b) + where + toSym r = toSym (numerator r) % toSym (denominator r) + {-# INLINE toSym #-} + +instance ToSym Rational SymAlgReal where + toSym v = con (fromRational v) + +-- Function +instance (ToSym b d, ToSym c a) => ToSym (a -> b) (c -> d) where + toSym = toSym1 + {-# INLINE toSym #-} + +instance (ToSym c a) => ToSym1 ((->) a) ((->) c) where + liftToSym l f = l . f . toSym + {-# INLINE liftToSym #-} + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''ToSym, ''ToSym1, ''ToSym2] + +deriveGADT + [ ''[], + ''Maybe, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''ToSym, ''ToSym1] + +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions, + ''NotRepresentableFPError + ] + [''ToSym] + +-- StateT +instance + (ToSym1 m1 m2, ToSym a1 a2) => + ToSym (StateLazy.StateT s m1 a1) (StateLazy.StateT s m2 a2) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2) => + ToSym1 (StateLazy.StateT s m1) (StateLazy.StateT s m2) + where + liftToSym f (StateLazy.StateT f1) = + StateLazy.StateT $ \s -> liftToSym (liftToSym2 f id) $ f1 s + {-# INLINE liftToSym #-} + +instance + (ToSym1 m1 m2, ToSym a1 a2) => + ToSym (StateStrict.StateT s m1 a1) (StateStrict.StateT s m2 a2) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2) => + ToSym1 (StateStrict.StateT s m1) (StateStrict.StateT s m2) + where + liftToSym f (StateStrict.StateT f1) = + StateStrict.StateT $ \s -> liftToSym (liftToSym2 f id) $ f1 s + {-# INLINE liftToSym #-} + +-- ReaderT +instance + (ToSym s2 s1, ToSym1 m1 m2, ToSym a1 a2) => + ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym s2 s1, ToSym1 m1 m2) => + ToSym1 (ReaderT s1 m1) (ReaderT s2 m2) + where + liftToSym :: + forall a b. + (ToSym s2 s1, ToSym1 m1 m2) => + (a -> b) -> + ReaderT s1 m1 a -> + ReaderT s2 m2 b + liftToSym f (ReaderT f1) = + ReaderT $ + liftToSym (liftToSym f) f1 + {-# INLINE liftToSym #-} + +-- IdentityT +instance (ToSym1 m m1, ToSym a b) => ToSym (IdentityT m a) (IdentityT m1 b) where + toSym = toSym1 + {-# INLINE toSym #-} + +instance (ToSym1 m m1) => ToSym1 (IdentityT m) (IdentityT m1) where + liftToSym f (IdentityT v) = IdentityT $ liftToSym f v + {-# INLINE liftToSym #-} + +-- Identity +instance {-# INCOHERENT #-} (ToSym a b) => ToSym (Identity a) (Identity b) where + toSym = toSym1 + {-# INLINE toSym #-} + +instance {-# INCOHERENT #-} (ToSym a b) => ToSym a (Identity b) where + toSym = Identity . toSym + {-# INLINE toSym #-} + +instance {-# INCOHERENT #-} (ToSym a b) => ToSym (Identity a) b where + toSym = toSym . runIdentity + {-# INLINE toSym #-} + +instance ToSym1 Identity Identity where + liftToSym f (Identity v) = Identity $ f v + {-# INLINE liftToSym #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) => + ToSym (Product l0 r0 a0) (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Product l0 r0) (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) => + ToSym (Sum l0 r0 a0) (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Sum l0 r0) (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (ToSym (f0 (g0 a0)) (f (g a))) => ToSym (Compose f0 g0 a0) (Compose f g a) + +instance + (ToSym1 f0 f, ToSym1 g0 g) => + ToSym1 (Compose f0 g0) (Compose f g) + where + liftToSym :: + forall a b. + (ToSym1 f0 f, ToSym1 g0 g) => + (a -> b) -> + Compose f0 g0 a -> + Compose f g b + liftToSym f (Compose v) = Compose $ liftToSym (liftToSym f) v + {-# INLINE liftToSym #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (ToSym a0 a) => ToSym (Const a0 b0) (Const a b) + +deriving via + (Default1 (Const a)) + instance + (ToSym a0 a) => ToSym1 (Const a0) (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (ToSym (f0 a0) (f a)) => ToSym (Alt f0 a0) (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (ToSym1 f0 f) => ToSym1 (Alt f0) (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (ToSym (f0 a0) (f a)) => ToSym (Ap f0 a0) (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (ToSym1 f0 f) => ToSym1 (Ap f0) (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance ToSym (U1 p0) (U1 p) + +deriving via (Default (V1 p)) instance ToSym (V1 p0) (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (ToSym c0 c) => ToSym (K1 i0 c0 p0) (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (ToSym (f0 p0) (f p)) => ToSym (M1 i0 c0 f0 p0) (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (ToSym (f0 p0) (f p), ToSym (g0 p0) (g p)) => + ToSym ((f0 :+: g0) p0) ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (ToSym (f0 p0) (f p), ToSym (g0 p0) (g p)) => + ToSym ((f0 :*: g0) p0) ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (ToSym p0 p) => ToSym (Par1 p0) (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (ToSym (f0 p0) (f p)) => ToSym (Rec1 f0 p0) (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (ToSym (f0 (g0 p0)) (f (g p))) => ToSym ((f0 :.: g0) p0) ((f :.: g) p) diff --git a/src/Grisette/Internal/Internal/Impl/Core/Data/Class/TryMerge.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/TryMerge.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/Class/TryMerge.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge +-- Copyright : (c) Sirui Lu 2023-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge () where + +import Control.Monad.Cont (ContT (ContT)) +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Functor.Sum (Sum (InL, InR)) +import qualified Data.Monoid as Monoid +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + Mergeable2 (liftRootStrategy2), + Mergeable3 (liftRootStrategy3), + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +instance (TryMerge m) => TryMerge (MaybeT m) where + tryMergeWithStrategy strategy (MaybeT ma) = + MaybeT $ tryMergeWithStrategy (liftRootStrategy strategy) ma + {-# INLINE tryMergeWithStrategy #-} + +instance (Mergeable e, TryMerge m) => TryMerge (ExceptT e m) where + tryMergeWithStrategy strategy (ExceptT ma) = + ExceptT $ tryMergeWithStrategy (liftRootStrategy strategy) ma + {-# INLINE tryMergeWithStrategy #-} + +instance (TryMerge m) => TryMerge (ReaderT r m) where + tryMergeWithStrategy strategy (ReaderT f) = + ReaderT $ \v -> tryMergeWithStrategy strategy $ f v + {-# INLINE tryMergeWithStrategy #-} + +instance (Mergeable s, TryMerge m) => TryMerge (StateLazy.StateT s m) where + tryMergeWithStrategy strategy (StateLazy.StateT f) = + StateLazy.StateT $ + \s -> tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) (f s) + {-# INLINE tryMergeWithStrategy #-} + +instance (Mergeable s, TryMerge m) => TryMerge (StateStrict.StateT s m) where + tryMergeWithStrategy strategy (StateStrict.StateT f) = + StateStrict.StateT $ + \s -> tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) (f s) + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, TryMerge m) => + TryMerge (WriterLazy.WriterT w m) + where + tryMergeWithStrategy strategy (WriterLazy.WriterT f) = + WriterLazy.WriterT $ + tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) f + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, TryMerge m) => + TryMerge (WriterStrict.WriterT w m) + where + tryMergeWithStrategy strategy (WriterStrict.WriterT f) = + WriterStrict.WriterT $ + tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) f + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, Mergeable s, TryMerge m) => + TryMerge (RWSStrict.RWST r w s m) + where + tryMergeWithStrategy strategy (RWSStrict.RWST f) = + RWSStrict.RWST $ + \r s -> + tryMergeWithStrategy + (liftRootStrategy3 strategy rootStrategy rootStrategy) + (f r s) + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, Mergeable s, TryMerge m) => + TryMerge (RWSLazy.RWST r w s m) + where + tryMergeWithStrategy strategy (RWSLazy.RWST f) = + RWSLazy.RWST $ + \r s -> + tryMergeWithStrategy + (liftRootStrategy3 strategy rootStrategy rootStrategy) + (f r s) + {-# INLINE tryMergeWithStrategy #-} + +instance (TryMerge m) => TryMerge (IdentityT m) where + tryMergeWithStrategy strategy (IdentityT ma) = + IdentityT $ tryMergeWithStrategy strategy ma + {-# INLINE tryMergeWithStrategy #-} + +instance (TryMerge m, Mergeable r) => TryMerge (ContT r m) where + tryMergeWithStrategy _ (ContT ma) = + ContT $ \c -> tryMergeWithStrategy rootStrategy (ma c) + {-# INLINE tryMergeWithStrategy #-} + +#define TRYMERGE_ID(T) \ + instance TryMerge (T) where { \ + tryMergeWithStrategy _ = id; {-# INLINE tryMergeWithStrategy #-} \ + } + +#if 1 +TRYMERGE_ID(Either a) +TRYMERGE_ID(Maybe) +TRYMERGE_ID(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/Internal/Impl/Core/Data/UnionBase.hs b/src/Grisette/Internal/Internal/Impl/Core/Data/UnionBase.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Core/Data/UnionBase.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Core.Data.UnionBase +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Core.Data.UnionBase + ( + ) +where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter (align, group, nest, vsep) +#else +import Data.Text.Prettyprint.Doc (align, group, nest, vsep) +#endif + +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import qualified Data.Binary as Binary +import Data.Bytes.Get (MonadGet (getWord8)) +import Data.Bytes.Put (MonadPut (putWord8)) +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Data.Functor.Classes + ( Eq1 (liftEq), + Show1 (liftShowsPrec), + showsPrec1, + showsUnaryWith, + ) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable.Lifted (Hashable1 (liftHashWithSalt), hashWithSalt1) +import qualified Data.Serialize as Cereal +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + ) +import Grisette.Internal.Core.Data.Class.PPrint + ( PPrint (pformatPrec), + PPrint1 (liftPFormatPrec), + condEnclose, + pformatPrec1, + ) +import Grisette.Internal.Internal.Decl.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + ifWithStrategy, + ) +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (allSymsS), + AllSyms1 (liftAllSymsS), + SomeSym (SomeSym), + ) + +instance Eq1 UnionBase where + liftEq e (UnionSingle a) (UnionSingle b) = e a b + liftEq e (UnionIf l1 i1 c1 t1 f1) (UnionIf l2 i2 c2 t2 f2) = + e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 + liftEq _ _ _ = False + +instance (NFData a) => NFData (UnionBase a) where + rnf = rnf1 + +instance NFData1 UnionBase where + liftRnf _a (UnionSingle a) = _a a + liftRnf _a (UnionIf a bo b l r) = + _a a `seq` + rnf bo `seq` + rnf b `seq` + liftRnf _a l `seq` + liftRnf _a r + +instance (Mergeable a, Serial a) => Serial (UnionBase a) where + serialize (UnionSingle a) = putWord8 0 >> serialize a + serialize (UnionIf _ _ c a b) = + putWord8 1 >> serialize c >> serialize a >> serialize b + deserialize = do + tag <- getWord8 + case tag of + 0 -> UnionSingle <$> deserialize + 1 -> + ifWithStrategy rootStrategy + <$> deserialize + <*> deserialize + <*> deserialize + _ -> fail "Invalid tag" + +instance (Mergeable a, Serial a) => Cereal.Serialize (UnionBase a) where + put = serialize + get = deserialize + +instance (Mergeable a, Serial a) => Binary.Binary (UnionBase a) where + put = serialize + get = deserialize + +instance Show1 UnionBase where + liftShowsPrec sp _ i (UnionSingle a) = showsUnaryWith sp "Single" i a + liftShowsPrec sp sl i (UnionIf _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrec sp sl + +instance (Show a) => Show (UnionBase a) where + showsPrec = showsPrec1 + +instance (PPrint a) => PPrint (UnionBase a) where + pformatPrec = pformatPrec1 + +instance PPrint1 UnionBase where + liftPFormatPrec fa _ n (UnionSingle a) = fa n a + liftPFormatPrec fa fl n (UnionIf _ _ cond t f) = + group $ + condEnclose (n > 10) "(" ")" $ + align $ + nest 2 $ + vsep + [ "If", + pformatPrec 11 cond, + liftPFormatPrec fa fl 11 t, + liftPFormatPrec fa fl 11 f + ] + +instance (Hashable a) => Hashable (UnionBase a) where + hashWithSalt = hashWithSalt1 + +instance Hashable1 UnionBase where + liftHashWithSalt f s (UnionSingle a) = s `hashWithSalt` (0 :: Int) `f` a + liftHashWithSalt f s (UnionIf _ _ c l r) = + let p = liftHashWithSalt f + in (s `hashWithSalt` (1 :: Int) `hashWithSalt` c) `p` l `p` r + +instance (AllSyms a) => AllSyms (UnionBase a) where + allSymsS (UnionSingle v) = allSymsS v + allSymsS (UnionIf _ _ c t f) = \l -> SomeSym c : (allSymsS t . allSymsS f $ l) + +instance AllSyms1 UnionBase where + liftAllSymsS fa (UnionSingle v) = fa v + liftAllSymsS fa (UnionIf _ _ c t f) = + \l -> SomeSym c : (liftAllSymsS fa t . liftAllSymsS fa f $ l) diff --git a/src/Grisette/Internal/Internal/Impl/SymPrim/AllSyms.hs b/src/Grisette/Internal/Internal/Impl/SymPrim/AllSyms.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/SymPrim/AllSyms.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.SymPrim.AllSyms +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.SymPrim.AllSyms () where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + AllSyms1 (liftAllSymsS), + AllSyms2, + allSymsS1, + ) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +deriveGADT + [ ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [''AllSyms, ''AllSyms1, ''AllSyms2] +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''AllSyms, ''AllSyms1] +deriveGADT + [ ''(), + ''AssertionError, + ''VerificationConditions + ] + [''AllSyms] + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (AllSyms (f a), AllSyms (g a)) => + AllSyms (Sum f g a) + +deriving via + (Default1 (Sum f g)) + instance + (AllSyms1 f, AllSyms1 g) => + AllSyms1 (Sum f g) + +-- IdentityT +instance + (AllSyms1 m, AllSyms a) => + AllSyms (IdentityT m a) + where + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} + +instance (AllSyms1 m) => AllSyms1 (IdentityT m) where + liftAllSymsS f (IdentityT a) = liftAllSymsS f a + {-# INLINE liftAllSymsS #-} + +#define CONCRETE_ALLSYMS(type) \ +instance AllSyms type where \ + allSymsS _ = id; \ + {-# INLINE allSymsS #-} + +#define CONCRETE_ALLSYMS_BV(type) \ +instance (KnownNat n, 1 <= n) => AllSyms (type n) where \ + allSymsS _ = id; \ + {-# INLINE allSymsS #-} + +#if 1 +CONCRETE_ALLSYMS(Bool) +CONCRETE_ALLSYMS(Integer) +CONCRETE_ALLSYMS(Char) +CONCRETE_ALLSYMS(Int) +CONCRETE_ALLSYMS(Int8) +CONCRETE_ALLSYMS(Int16) +CONCRETE_ALLSYMS(Int32) +CONCRETE_ALLSYMS(Int64) +CONCRETE_ALLSYMS(Word) +CONCRETE_ALLSYMS(Word8) +CONCRETE_ALLSYMS(Word16) +CONCRETE_ALLSYMS(Word32) +CONCRETE_ALLSYMS(Word64) +CONCRETE_ALLSYMS(Float) +CONCRETE_ALLSYMS(Double) +CONCRETE_ALLSYMS(B.ByteString) +CONCRETE_ALLSYMS(T.Text) +CONCRETE_ALLSYMS(FPRoundingMode) +CONCRETE_ALLSYMS_BV(WordN) +CONCRETE_ALLSYMS_BV(IntN) +CONCRETE_ALLSYMS(AlgReal) +#endif + +instance AllSyms (Proxy a) where + allSymsS _ = id + {-# INLINE allSymsS #-} + +instance AllSyms1 Proxy where + liftAllSymsS _ _ = id + {-# INLINE liftAllSymsS #-} + +instance (AllSyms a) => AllSyms (Ratio a) where + allSymsS r = allSymsS (numerator r) . allSymsS (denominator r) + {-# INLINE allSymsS #-} + +instance (ValidFP eb sb) => AllSyms (FP eb sb) where + allSymsS _ = id + {-# INLINE allSymsS #-} diff --git a/src/Grisette/Internal/Internal/Impl/Unified/BVFPConversion.hs b/src/Grisette/Internal/Internal/Impl/Unified/BVFPConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/BVFPConversion.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.BVFPConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.BVFPConversion + ( UnifiedBVFPConversion, + SafeUnifiedBVFPConversion, + AllUnifiedBVFPConversion, + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (+), type (<=)) +import Grisette.Internal.Internal.Decl.Unified.BVFPConversion + ( AllUnifiedBVFPConversion, + SafeUnifiedBVFPConversion, + SafeUnifiedBVFPConversionImpl, + UnifiedBVFPConversion, + UnifiedBVFPConversionImpl, + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedBV + ( UnifiedBVImpl (GetIntN, GetWordN), + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP + ( UnifiedFPImpl (GetFP, GetFPRoundingMode), + ) +import Grisette.Internal.Internal.Impl.Unified.UnifiedBV () +import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.Unified.Class.UnifiedSafeBitCast (UnifiedSafeBitCast) +import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) + +instance + (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => + UnifiedBVFPConversionImpl + 'C + WordN + IntN + FP + n + eb + sb + (WordN n) + (IntN n) + (FP eb sb) + FPRoundingMode + +instance + (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => + UnifiedBVFPConversionImpl + 'S + SymWordN + SymIntN + SymFP + n + eb + sb + (SymWordN n) + (SymIntN n) + (SymFP eb sb) + SymFPRoundingMode + +instance + ( UnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd, + UnifiedSafeBitCast mode NotRepresentableFPError fp int m, + UnifiedSafeBitCast mode NotRepresentableFPError fp word m, + UnifiedSafeFromFP mode NotRepresentableFPError word fp fprd m + ) => + SafeUnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd m + +instance + ( SafeUnifiedBVFPConversionImpl + mode + (GetWordN mode) + (GetIntN mode) + (GetFP mode) + n + eb + sb + (GetWordN mode n) + (GetIntN mode n) + (GetFP mode eb sb) + (GetFPRoundingMode mode) + m + ) => + SafeUnifiedBVFPConversion mode n eb sb m + +instance + ( UnifiedBVFPConversionImpl + (mode :: EvalModeTag) + (GetWordN mode) + (GetIntN mode) + (GetFP mode) + n + eb + sb + (GetWordN mode n) + (GetIntN mode n) + (GetFP mode eb sb) + (GetFPRoundingMode mode) + ) => + UnifiedBVFPConversion mode n eb sb + +instance + ( forall n eb sb. + (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => + UnifiedBVFPConversion mode n eb sb, + forall n eb sb m. + ( UnifiedBranching mode m, + ValidFP eb sb, + KnownNat n, + 1 <= n, + n ~ (eb + sb), + MonadError NotRepresentableFPError m + ) => + SafeUnifiedBVFPConversion mode n eb sb m + ) => + AllUnifiedBVFPConversion mode diff --git a/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedITEOp.hs b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedITEOp.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedITEOp.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp + ( symIte, + symIteMerge, + ) +where + +import Control.Monad.Identity (Identity (runIdentity)) +import Data.Kind (Constraint) +import Data.Type.Bool (If) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) +import qualified Grisette.Internal.Core.Data.Class.ITEOp +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import qualified Grisette.Internal.Core.Data.Class.PlainUnion +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp + ( UnifiedITEOp (withBaseITEOp), + ) +import Grisette.Internal.Unified.BaseMonad (BaseMonad) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S), IsConMode) +import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.ITEOp.symIte` operation. +-- +-- This function isn't able to infer the mode of the boolean variable, so you +-- need to provide the mode explicitly. For example: +-- +-- > symIte @mode (a .== b) ... +-- > symIte (a .== b :: SymBool) ... +-- > symIte (a .== b :: GetBool mode) ... +symIte :: + forall mode v. + (DecideEvalMode mode, UnifiedITEOp mode v) => + GetBool mode -> + v -> + v -> + v +symIte c a b = + withMode @mode + (withBaseITEOp @mode @v $ if c then a else b) + ( withBaseITEOp @mode @v $ + Grisette.Internal.Core.Data.Class.ITEOp.symIte c a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.PlainUnion.symIteMerge` +-- operation. +-- +-- This function isn't able to infer the mode of the base monad from the result, +-- so you need to provide the mode explicitly. For example: +-- +-- > symIteMerge @mode ... +-- > symIteMerge (... :: BaseMonad mode v) ... +symIteMerge :: + forall mode v. + (DecideEvalMode mode, UnifiedITEOp mode v, Mergeable v) => + BaseMonad mode v -> + v +symIteMerge m = + withMode @mode + (withBaseITEOp @mode @v $ runIdentity m) + ( withBaseITEOp @mode @v $ + Grisette.Internal.Core.Data.Class.PlainUnion.symIteMerge m + ) + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (() :: Constraint) (ITEOp a) + ) => + UnifiedITEOp mode a + where + withBaseITEOp r = withMode @mode r r + {-# INLINE withBaseITEOp #-} + +instance (UnifiedITEOp 'S v, Mergeable v) => UnifiedITEOp 'S (Union v) where + withBaseITEOp r = withBaseITEOp @'S @v r + {-# INLINE withBaseITEOp #-} diff --git a/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSimpleMergeable.hs b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSimpleMergeable.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable + ( mrgIf, + liftBaseMonad, + mrgIte, + mrgIte1, + liftMrgIte, + mrgIte2, + liftMrgIte2, + simpleMerge, + ) +where + +import Control.Monad.Cont (ContT) +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity (runIdentity), IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Trans.RWS.Lazy as RWSLazy +import qualified Control.Monad.Trans.RWS.Strict as RWSStrict +import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.State.Lazy as StateLazy +import qualified Control.Monad.Trans.State.Strict as StateStrict +import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy +import qualified Control.Monad.Trans.Writer.Strict as WriterStrict +import Data.Kind (Constraint) +import Data.Type.Bool (If) +import Grisette.Internal.Core.Control.Exception (AssertionError) +import Grisette.Internal.Core.Control.Monad.Union (liftUnion) +import Grisette.Internal.Core.Data.Class.GenSym (FreshT) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1) +import qualified Grisette.Internal.Core.Data.Class.PlainUnion as Grisette +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable, + SimpleMergeable1, + SimpleMergeable2, + SymBranching, + ) +import qualified Grisette.Internal.Core.Data.Class.SimpleMergeable +import qualified Grisette.Internal.Core.Data.Class.SimpleMergeable as Grisette +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + ) +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + UnifiedSimpleMergeable (withBaseSimpleMergeable), + UnifiedSimpleMergeable1 (withBaseSimpleMergeable1), + UnifiedSimpleMergeable2 (withBaseSimpleMergeable2), + ) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT) +import Grisette.Internal.Unified.BaseMonad (BaseMonad) +import Grisette.Internal.Unified.EvalModeTag (IsConMode) +import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- | Unified `Grisette.mrgIf`. +-- +-- This function isn't able to infer the mode of the boolean variable, so you +-- need to provide the mode explicitly. For example: +-- +-- > mrgIf @mode (a .== b) ... +-- > mrgIf (a .== b :: SymBool) ... +-- > mrgIf (a .== b :: GetBool mode) ... +mrgIf :: + forall mode a m. + (DecideEvalMode mode, Mergeable a, UnifiedBranching mode m) => + GetBool mode -> + m a -> + m a -> + m a +mrgIf c t e = + withMode @mode + (if c then t else e) + (withBaseBranching @mode @m $ Grisette.mrgIf c t e) +{-# INLINE mrgIf #-} + +-- | Unified lifting of a base monad. +liftBaseMonad :: + forall mode a m. + ( Applicative m, + UnifiedBranching mode m, + Mergeable a + ) => + BaseMonad mode a -> + m a +liftBaseMonad b = + withMode @mode + (withBaseBranching @mode @m $ mrgSingle . runIdentity $ b) + (withBaseBranching @mode @m $ liftUnion b) +{-# INLINE liftBaseMonad #-} + +-- | Unified merge of simply mergeable values in the base monad. +simpleMerge :: + forall mode a. + (DecideEvalMode mode, UnifiedSimpleMergeable mode a) => + BaseMonad mode a -> + a +simpleMerge = + withMode @mode + runIdentity + (withBaseSimpleMergeable @mode @a Grisette.simpleMerge) + +-- | Unified `Grisette.mrgIte`. +mrgIte :: + forall mode a. + (DecideEvalMode mode, UnifiedSimpleMergeable mode a) => + GetBool mode -> + a -> + a -> + a +mrgIte c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable @mode @a $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte c t e + ) + +-- | Unified `Grisette.mrgIte1`. +mrgIte1 :: + forall mode f a. + ( DecideEvalMode mode, + UnifiedSimpleMergeable1 mode f, + UnifiedSimpleMergeable mode a + ) => + GetBool mode -> + f a -> + f a -> + f a +mrgIte1 c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable @mode @a $ + withBaseSimpleMergeable1 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte1 c t e + ) + +-- | Unified `Grisette.liftMrgIte`. +liftMrgIte :: + forall mode f a. + ( DecideEvalMode mode, + UnifiedSimpleMergeable1 mode f + ) => + (GetBool mode -> a -> a -> a) -> + GetBool mode -> + f a -> + f a -> + f a +liftMrgIte f c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable1 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.liftMrgIte f c t e + ) + +-- | Unified `Grisette.mrgIte2`. +mrgIte2 :: + forall mode f a b. + ( DecideEvalMode mode, + UnifiedSimpleMergeable2 mode f, + UnifiedSimpleMergeable mode a, + UnifiedSimpleMergeable mode b + ) => + GetBool mode -> + f a b -> + f a b -> + f a b +mrgIte2 c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable @mode @a $ + withBaseSimpleMergeable @mode @b $ + withBaseSimpleMergeable2 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte2 c t e + ) + +-- | Unified `Grisette.liftMrgIte2`. +liftMrgIte2 :: + forall mode f a b. + ( DecideEvalMode mode, + UnifiedSimpleMergeable2 mode f + ) => + (GetBool mode -> a -> a -> a) -> + (GetBool mode -> b -> b -> b) -> + GetBool mode -> + f a b -> + f a b -> + f a b +liftMrgIte2 f g c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable2 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.liftMrgIte2 f g c t e + ) + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + TryMerge m, + If (IsConMode mode) ((TryMerge m) :: Constraint) (SymBranching m) + ) => + UnifiedBranching mode m + where + withBaseBranching r = r + {-# INLINE withBaseBranching #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + Mergeable m, + If (IsConMode mode) (() :: Constraint) (SimpleMergeable m) + ) => + UnifiedSimpleMergeable mode m + where + withBaseSimpleMergeable r = r + {-# INLINE withBaseSimpleMergeable #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 m) + ) => + UnifiedSimpleMergeable1 mode m + where + withBaseSimpleMergeable1 r = r + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 m) + ) => + UnifiedSimpleMergeable2 mode m + where + withBaseSimpleMergeable2 r = r + {-# INLINE withBaseSimpleMergeable2 #-} + +deriveGADT + [ ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,) + ] + [ ''UnifiedSimpleMergeable, + ''UnifiedSimpleMergeable1, + ''UnifiedSimpleMergeable2 + ] + +deriveGADT + [''Identity] + [''UnifiedSimpleMergeable, ''UnifiedSimpleMergeable1] + +deriveGADT + [''(), ''AssertionError] + [''UnifiedSimpleMergeable] + +instance + (DecideEvalMode mode, UnifiedSimpleMergeable mode b) => + UnifiedSimpleMergeable mode (a -> b) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseSimpleMergeable @mode @b r) + (withBaseSimpleMergeable @mode @b r) + {-# INLINE withBaseSimpleMergeable #-} + +instance (DecideEvalMode mode) => UnifiedSimpleMergeable1 mode ((->) a) where + withBaseSimpleMergeable1 r = withMode @mode r r + {-# INLINE withBaseSimpleMergeable1 #-} + +instance (DecideEvalMode mode) => UnifiedSimpleMergeable2 mode (->) where + withBaseSimpleMergeable2 r = withMode @mode r r + {-# INLINE withBaseSimpleMergeable2 #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable a, Mergeable1 m) => + UnifiedSimpleMergeable mode (FreshT m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (FreshT m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedBranching mode (FreshT m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable a, Mergeable1 m) => + UnifiedSimpleMergeable mode (MaybeT m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (MaybeT m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedBranching mode (MaybeT m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable a, Mergeable1 m) => + UnifiedSimpleMergeable mode (IdentityT m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (IdentityT m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedBranching mode (IdentityT m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable a, Mergeable1 m) => + UnifiedSimpleMergeable mode (ReaderT r m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (ReaderT r m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m) => + UnifiedBranching mode (ReaderT r m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable s, + Mergeable a, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (StateLazy.StateT s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable s) => + UnifiedSimpleMergeable1 mode (StateLazy.StateT s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable s + ) => + UnifiedBranching mode (StateLazy.StateT s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable s, + Mergeable a, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (StateStrict.StateT s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable s) => + UnifiedSimpleMergeable1 mode (StateStrict.StateT s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable s + ) => + UnifiedBranching mode (StateStrict.StateT s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Mergeable a, + Monoid w, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (WriterLazy.WriterT w m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable1 m + ) => + UnifiedSimpleMergeable1 mode (WriterLazy.WriterT w m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (WriterLazy.WriterT w m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Mergeable a, + Monoid w, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (WriterStrict.WriterT w m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable1 m + ) => + UnifiedSimpleMergeable1 mode (WriterStrict.WriterT w m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Monoid w, + Mergeable w, + Mergeable1 m + ) => + UnifiedBranching mode (WriterStrict.WriterT w m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable e, + Mergeable a, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (ExceptT e m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable e, Mergeable1 m) => + UnifiedSimpleMergeable1 mode (ExceptT e m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (DecideEvalMode mode, Mergeable e, UnifiedBranching mode m) => + UnifiedBranching mode (ExceptT e m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable r, + Mergeable a, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (ContT r m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (DecideEvalMode mode, UnifiedBranching mode m, Mergeable r, Mergeable1 m) => + UnifiedSimpleMergeable1 mode (ContT r m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (DecideEvalMode mode, Mergeable r, UnifiedBranching mode m, Mergeable1 m) => + UnifiedBranching mode (ContT r m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s, + Mergeable a, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (RWSLazy.RWST r w s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s, + Mergeable1 m + ) => + UnifiedSimpleMergeable1 mode (RWSLazy.RWST r w s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable s, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (RWSLazy.RWST r w s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s, + Mergeable a, + Mergeable1 m + ) => + UnifiedSimpleMergeable mode (RWSStrict.RWST r w s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s + ) => + UnifiedSimpleMergeable1 mode (RWSStrict.RWST r w s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( DecideEvalMode mode, + UnifiedBranching mode m, + Mergeable s, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (RWSStrict.RWST r w s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} diff --git a/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymEq.hs b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymEq.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq + ( (.==), + (./=), + symDistinct, + liftSymEq, + symEq1, + liftSymEq2, + symEq2, + ) +where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity, IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2), eq1, eq2) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ratio (Ratio) +import qualified Data.Text as T +import Data.Type.Bool (If) +import Data.Word (Word16, Word32, Word64, Word8) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( SymEq, + SymEq1, + SymEq2, + ) +import qualified Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq as SymEq +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq + ( UnifiedSymEq (withBaseSymEq), + UnifiedSymEq1 (withBaseSymEq1), + UnifiedSymEq2 (withBaseSymEq2), + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode) +import Grisette.Internal.TH.GADT.Common + ( DeriveConfig (bitSizePositions, fpBitSizePositions), + ) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT, deriveGADTWith) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S), IsConMode) +import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymEq..==)`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > a .== b :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Internal.Unified.Class.UnifiedBranching.mrgIf`. +(.==) :: + forall mode a. (DecideEvalMode mode, UnifiedSymEq mode a) => a -> a -> GetBool mode +(.==) a b = + withMode @mode + (withBaseSymEq @mode @a $ a == b) + (withBaseSymEq @mode @a $ a SymEq..== b) + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymEq../=)`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > a ./= b :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Internal.Unified.Class.UnifiedBranching.mrgIf`. +(./=) :: + forall mode a. (DecideEvalMode mode, UnifiedSymEq mode a) => a -> a -> GetBool mode +(./=) a b = + withMode @mode + (withBaseSymEq @mode @a $ a /= b) + (withBaseSymEq @mode @a $ a SymEq../= b) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symDistinct`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > symDistinct l :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Internal.Unified.Class.UnifiedBranching.mrgIf`. +symDistinct :: + forall mode a. (DecideEvalMode mode, UnifiedSymEq mode a) => [a] -> GetBool mode +symDistinct l = + withMode @mode + ( withBaseSymEq @mode @a $ + SymEq.distinct l + ) + ( withBaseSymEq @mode @a $ + SymEq.symDistinct l + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq`. +liftSymEq :: + forall mode f a b. + (DecideEvalMode mode, UnifiedSymEq1 mode f) => + (a -> b -> GetBool mode) -> + f a -> + f b -> + GetBool mode +liftSymEq f a b = + withMode @mode + (withBaseSymEq1 @mode @f $ liftEq f a b) + ( withBaseSymEq1 @mode @f $ + SymEq.liftSymEq f a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq1`. +symEq1 :: + forall mode f a. + (DecideEvalMode mode, UnifiedSymEq mode a, UnifiedSymEq1 mode f) => + f a -> + f a -> + GetBool mode +symEq1 a b = + withMode @mode + (withBaseSymEq1 @mode @f $ withBaseSymEq @mode @a eq1 a b) + ( withBaseSymEq1 @mode @f $ + withBaseSymEq @mode @a $ + SymEq.symEq1 a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq2`. +liftSymEq2 :: + forall mode f a b c d. + (DecideEvalMode mode, UnifiedSymEq2 mode f) => + (a -> b -> GetBool mode) -> + (c -> d -> GetBool mode) -> + f a c -> + f b d -> + GetBool mode +liftSymEq2 f a b = + withMode @mode + (withBaseSymEq2 @mode @f $ liftEq2 f a b) + ( withBaseSymEq2 @mode @f $ + SymEq.liftSymEq2 f a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq2`. +symEq2 :: + forall mode f a b. + ( DecideEvalMode mode, + UnifiedSymEq mode a, + UnifiedSymEq mode b, + UnifiedSymEq2 mode f + ) => + f a b -> + f a b -> + GetBool mode +symEq2 a b = + withMode @mode + ( withBaseSymEq2 @mode @f $ + withBaseSymEq @mode @a $ + withBaseSymEq @mode @b eq2 a b + ) + ( withBaseSymEq2 @mode @f $ + withBaseSymEq @mode @a $ + withBaseSymEq @mode @b $ + SymEq.symEq2 a b + ) + +instance + {-# INCOHERENT #-} + (DecideEvalMode mode, If (IsConMode mode) (Eq a) (SymEq a)) => + UnifiedSymEq mode a + where + withBaseSymEq r = r + {-# INLINE withBaseSymEq #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (Eq1 f) (SymEq1 f), + forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a) + ) => + UnifiedSymEq1 mode f + where + withBaseSymEq1 r = r + {-# INLINE withBaseSymEq1 #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (Eq2 f) (SymEq2 f), + forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a) + ) => + UnifiedSymEq2 mode f + where + withBaseSymEq2 r = r + {-# INLINE withBaseSymEq2 #-} + +instance (UnifiedSymEq 'S v) => UnifiedSymEq 'S (Union v) where + withBaseSymEq r = withBaseSymEq @'S @v r + {-# INLINE withBaseSymEq #-} + +deriveGADT + [ ''Either, + ''(,) + ] + [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2] + +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''UnifiedSymEq, ''UnifiedSymEq1] + +deriveGADT + [ ''Bool, + ''Integer, + ''Char, + ''Int, + ''Int8, + ''Int16, + ''Int32, + ''Int64, + ''Word, + ''Word8, + ''Word16, + ''Word32, + ''Word64, + ''Float, + ''Double, + ''B.ByteString, + ''T.Text, + ''FPRoundingMode, + ''(), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Ratio + ] + [''UnifiedSymEq] + +#if MIN_VERSION_base(4,16,0) +deriveGADT + [ ''(,,), + ''(,,,) + ] + [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2] +#else +deriveGADT + [ ''(,,), + ''(,,,) + ] + [''UnifiedSymEq] +#endif + +deriveGADTWith + (mempty {bitSizePositions = [0]}) + [''WordN, ''IntN] + [''UnifiedSymEq] + +deriveGADTWith + (mempty {fpBitSizePositions = [(0, 1)]}) + [''FP] + [''UnifiedSymEq] + +-- Sum +instance + ( DecideEvalMode mode, + UnifiedSymEq1 mode f, + UnifiedSymEq1 mode g, + UnifiedSymEq mode a + ) => + UnifiedSymEq mode (Sum f g a) + where + withBaseSymEq r = + withMode @mode + ( withBaseSymEq1 @mode @f $ + withBaseSymEq1 @mode @g $ + withBaseSymEq @mode @a r + ) + ( withBaseSymEq1 @mode @f $ + withBaseSymEq1 @mode @g $ + withBaseSymEq @mode @a r + ) + {-# INLINE withBaseSymEq #-} + +instance + (DecideEvalMode mode, UnifiedSymEq1 mode f, UnifiedSymEq1 mode g) => + UnifiedSymEq1 mode (Sum f g) + where + withBaseSymEq1 r = + withMode @mode + (withBaseSymEq1 @mode @f $ withBaseSymEq1 @mode @g r) + (withBaseSymEq1 @mode @f $ withBaseSymEq1 @mode @g r) + {-# INLINE withBaseSymEq1 #-} + +-- IdentityT +instance + (DecideEvalMode mode, UnifiedSymEq1 mode m, UnifiedSymEq mode a) => + UnifiedSymEq mode (IdentityT m a) + where + withBaseSymEq r = + withMode @mode + (withBaseSymEq1 @mode @m $ withBaseSymEq @mode @a r) + (withBaseSymEq1 @mode @m $ withBaseSymEq @mode @a r) + {-# INLINE withBaseSymEq #-} + +instance + (DecideEvalMode mode, UnifiedSymEq1 mode m) => + UnifiedSymEq1 mode (IdentityT m) + where + withBaseSymEq1 r = + withMode @mode (withBaseSymEq1 @mode @m r) (withBaseSymEq1 @mode @m r) + {-# INLINE withBaseSymEq1 #-} diff --git a/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymOrd.hs b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymOrd.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd + ( (.<=), + (.<), + (.>=), + (.>), + symCompare, + liftSymCompare, + symCompare1, + liftSymCompare2, + symCompare2, + symMax, + symMin, + mrgMax, + mrgMin, + ) +where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity (runIdentity), IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes + ( Ord1 (liftCompare), + Ord2 (liftCompare2), + compare1, + compare2, + ) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ratio (Ratio) +import qualified Data.Text as T +import Data.Type.Bool (If) +import Data.Word (Word16, Word32, Word64, Word8) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (tryMerge) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + ( SymOrd, + SymOrd1, + SymOrd2, + ) +import qualified Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd as SymOrd +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp + ( UnifiedITEOp (withBaseITEOp), + ) +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd + ( UnifiedSymOrd (withBaseSymOrd), + UnifiedSymOrd1 (withBaseSymOrd1), + UnifiedSymOrd2 (withBaseSymOrd2), + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode) +import Grisette.Internal.TH.GADT.Common + ( DeriveConfig (bitSizePositions, fpBitSizePositions), + ) +import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT, deriveGADTWith) +import Grisette.Internal.Unified.BaseMonad (BaseMonad) +import Grisette.Internal.Unified.EvalModeTag + ( EvalModeTag (S), + IsConMode, + ) +import Grisette.Internal.Unified.UnifiedBool (GetBool) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<=)`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > a .<= b :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Internal.Unified.Class.UnifiedBranching.mrgIf`. +(.<=) :: + forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.<=) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a <= b) + (withBaseSymOrd @mode @a $ a SymOrd..<= b) +{-# INLINE (.<=) #-} + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<)`. +(.<) :: + forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.<) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a < b) + (withBaseSymOrd @mode @a $ a SymOrd..< b) +{-# INLINE (.<) #-} + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>=)`. +(.>=) :: + forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.>=) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a >= b) + (withBaseSymOrd @mode @a $ a SymOrd..>= b) +{-# INLINE (.>=) #-} + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>)`. +(.>) :: + forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.>) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a > b) + (withBaseSymOrd @mode @a $ a SymOrd..> b) +{-# INLINE (.>) #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare`. +symCompare :: + forall mode a ctx. + (DecideEvalMode mode, UnifiedSymOrd mode a, Monad ctx) => + a -> + a -> + BaseMonad mode Ordering +symCompare x y = + withMode @mode + (withBaseSymOrd @mode @a $ return $ compare x y) + ( withBaseSymOrd @mode @a $ + SymOrd.symCompare x y + ) +{-# INLINE symCompare #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare`. +liftSymCompare :: + forall mode f a b. + (DecideEvalMode mode, UnifiedSymOrd1 mode f) => + (a -> b -> BaseMonad mode Ordering) -> + f a -> + f b -> + BaseMonad mode Ordering +liftSymCompare f a b = + withMode @mode + ( withBaseSymOrd1 @mode @f $ + return $ + liftCompare (\x y -> runIdentity $ f x y) a b + ) + ( withBaseSymOrd1 @mode @f $ + SymOrd.liftSymCompare f a b + ) +{-# INLINE liftSymCompare #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare1`. +symCompare1 :: + forall mode f a. + (DecideEvalMode mode, UnifiedSymOrd mode a, UnifiedSymOrd1 mode f) => + f a -> + f a -> + BaseMonad mode Ordering +symCompare1 a b = + withMode @mode + (withBaseSymOrd1 @mode @f $ withBaseSymOrd @mode @a $ return $ compare1 a b) + ( withBaseSymOrd1 @mode @f $ + withBaseSymOrd @mode @a $ + SymOrd.symCompare1 a b + ) +{-# INLINE symCompare1 #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare2`. +liftSymCompare2 :: + forall mode f a b c d. + (DecideEvalMode mode, UnifiedSymOrd2 mode f) => + (a -> b -> BaseMonad mode Ordering) -> + (c -> d -> BaseMonad mode Ordering) -> + f a c -> + f b d -> + BaseMonad mode Ordering +liftSymCompare2 f g a b = + withMode @mode + ( withBaseSymOrd2 @mode @f $ + return $ + liftCompare2 + (\x y -> runIdentity $ f x y) + (\x y -> runIdentity $ g x y) + a + b + ) + ( withBaseSymOrd2 @mode @f $ + SymOrd.liftSymCompare2 f g a b + ) +{-# INLINE liftSymCompare2 #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare2`. +symCompare2 :: + forall mode f a b. + ( DecideEvalMode mode, + UnifiedSymOrd mode a, + UnifiedSymOrd mode b, + UnifiedSymOrd2 mode f + ) => + f a b -> + f a b -> + BaseMonad mode Ordering +symCompare2 a b = + withMode @mode + ( withBaseSymOrd2 @mode @f $ + withBaseSymOrd @mode @a $ + withBaseSymOrd @mode @b $ + return $ + compare2 a b + ) + ( withBaseSymOrd2 @mode @f $ + withBaseSymOrd @mode @a $ + withBaseSymOrd @mode @b $ + SymOrd.symCompare2 a b + ) +{-# INLINE symCompare2 #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMax`. +symMax :: + forall mode a. + (UnifiedSymOrd mode a, UnifiedITEOp mode a, DecideEvalMode mode) => + a -> + a -> + a +symMax x y = + withMode @mode + (withBaseSymOrd @mode @a $ max x y) + ( withBaseSymOrd @mode @a $ + withBaseITEOp @mode @a + SymOrd.symMax + x + y + ) +{-# INLINE symMax #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMin`. +symMin :: + forall mode a. + (UnifiedSymOrd mode a, UnifiedITEOp mode a, DecideEvalMode mode) => + a -> + a -> + a +symMin x y = + withMode @mode + (withBaseSymOrd @mode @a $ min x y) + ( withBaseSymOrd @mode @a $ + withBaseITEOp @mode @a + SymOrd.symMin + x + y + ) +{-# INLINE symMin #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.mrgMax`. +mrgMax :: + forall mode a m. + ( UnifiedSymOrd mode a, + UnifiedBranching mode m, + DecideEvalMode mode, + Applicative m, + Mergeable a + ) => + a -> + a -> + m a +mrgMax x y = + withMode @mode + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + tryMerge $ + pure $ + max x y + ) + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + SymOrd.mrgMax x y + ) +{-# INLINE mrgMax #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.mrgMin`. +mrgMin :: + forall mode a m. + ( UnifiedSymOrd mode a, + UnifiedBranching mode m, + DecideEvalMode mode, + Applicative m, + Mergeable a + ) => + a -> + a -> + m a +mrgMin x y = + withMode @mode + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + tryMerge $ + pure $ + min x y + ) + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + SymOrd.mrgMin x y + ) +{-# INLINE mrgMin #-} + +instance + {-# INCOHERENT #-} + (DecideEvalMode mode, If (IsConMode mode) (Ord a) (SymOrd a)) => + UnifiedSymOrd mode a + where + withBaseSymOrd r = r + {-# INLINE withBaseSymOrd #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (Ord1 f) (SymOrd1 f), + forall a. (UnifiedSymOrd mode a) => UnifiedSymOrd mode (f a) + ) => + UnifiedSymOrd1 mode f + where + withBaseSymOrd1 r = r + {-# INLINE withBaseSymOrd1 #-} + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + If (IsConMode mode) (Ord2 f) (SymOrd2 f), + forall a. (UnifiedSymOrd mode a) => UnifiedSymOrd1 mode (f a) + ) => + UnifiedSymOrd2 mode f + where + withBaseSymOrd2 r = r + {-# INLINE withBaseSymOrd2 #-} + +instance (UnifiedSymOrd 'S v) => UnifiedSymOrd 'S (Union v) where + withBaseSymOrd r = withBaseSymOrd @'S @v r + {-# INLINE withBaseSymOrd #-} + +deriveGADT + [ ''Either, + ''(,) + ] + [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2] + +deriveGADT + [ ''[], + ''Maybe, + ''Identity, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT + ] + [''UnifiedSymOrd, ''UnifiedSymOrd1] + +deriveGADT + [ ''Bool, + ''Integer, + ''Char, + ''Int, + ''Int8, + ''Int16, + ''Int32, + ''Int64, + ''Word, + ''Word8, + ''Word16, + ''Word32, + ''Word64, + ''Float, + ''Double, + ''B.ByteString, + ''T.Text, + ''FPRoundingMode, + ''(), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions + ] + [''UnifiedSymOrd] + +#if MIN_VERSION_base(4,16,0) +deriveGADT + [ ''(,,), + ''(,,,) + ] + [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2] +#else +deriveGADT + [ ''(,,), + ''(,,,) + ] + [''UnifiedSymOrd] +#endif + +deriveGADTWith + (mempty {bitSizePositions = [0]}) + [''WordN, ''IntN] + [''UnifiedSymOrd] + +deriveGADTWith + (mempty {fpBitSizePositions = [(0, 1)]}) + [''FP] + [''UnifiedSymOrd] + +instance + (DecideEvalMode mode, UnifiedSymOrd mode a, Integral a) => + UnifiedSymOrd mode (Ratio a) + where + withBaseSymOrd r = + withMode @mode (withBaseSymOrd @mode @a r) (withBaseSymOrd @mode @a r) + {-# INLINE withBaseSymOrd #-} + +-- Sum +instance + ( DecideEvalMode mode, + UnifiedSymOrd1 mode f, + UnifiedSymOrd1 mode g, + UnifiedSymOrd mode a + ) => + UnifiedSymOrd mode (Sum f g a) + where + withBaseSymOrd r = + withMode @mode + ( withBaseSymOrd1 @mode @f $ + withBaseSymOrd1 @mode @g $ + withBaseSymOrd @mode @a r + ) + ( withBaseSymOrd1 @mode @f $ + withBaseSymOrd1 @mode @g $ + withBaseSymOrd @mode @a r + ) + {-# INLINE withBaseSymOrd #-} + +instance + (DecideEvalMode mode, UnifiedSymOrd1 mode f, UnifiedSymOrd1 mode g) => + UnifiedSymOrd1 mode (Sum f g) + where + withBaseSymOrd1 r = + withMode @mode + (withBaseSymOrd1 @mode @f $ withBaseSymOrd1 @mode @g r) + (withBaseSymOrd1 @mode @f $ withBaseSymOrd1 @mode @g r) + {-# INLINE withBaseSymOrd1 #-} + +-- IdentityT +instance + (DecideEvalMode mode, UnifiedSymOrd1 mode m, UnifiedSymOrd mode a) => + UnifiedSymOrd mode (IdentityT m a) + where + withBaseSymOrd r = + withMode @mode + (withBaseSymOrd1 @mode @m $ withBaseSymOrd @mode @a r) + (withBaseSymOrd1 @mode @m $ withBaseSymOrd @mode @a r) + {-# INLINE withBaseSymOrd #-} + +instance + (DecideEvalMode mode, UnifiedSymOrd1 mode m) => + UnifiedSymOrd1 mode (IdentityT m) + where + withBaseSymOrd1 r = + withMode @mode (withBaseSymOrd1 @mode @m r) (withBaseSymOrd1 @mode @m r) + {-# INLINE withBaseSymOrd1 #-} diff --git a/src/Grisette/Internal/Internal/Impl/Unified/EvalMode.hs b/src/Grisette/Internal/Internal/Impl/Unified/EvalMode.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/EvalMode.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.EvalMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.EvalMode () where + +import Grisette.Internal.Internal.Decl.Unified.EvalMode + ( EvalModeAll, + EvalModeBV, + EvalModeBase, + EvalModeFP, + ) +import Grisette.Internal.Internal.Impl.Unified.BVFPConversion () +import Grisette.Internal.Internal.Impl.Unified.FPFPConversion () +import Grisette.Internal.Internal.Impl.Unified.UnifiedBV () +import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) + +instance EvalModeBase 'C + +instance EvalModeBase 'S + +instance EvalModeAll 'C + +instance EvalModeAll 'S + +instance EvalModeBV 'C + +instance EvalModeBV 'S + +instance EvalModeFP 'C + +instance EvalModeFP 'S diff --git a/src/Grisette/Internal/Internal/Impl/Unified/FPFPConversion.hs b/src/Grisette/Internal/Internal/Impl/Unified/FPFPConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/FPFPConversion.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.FPFPConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.FPFPConversion () where + +import Grisette.Internal.Internal.Decl.Unified.FPFPConversion + ( AllUnifiedFPFPConversion, + UnifiedFPFPConversion, + UnifiedFPFPConversionImpl, + ) +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP + ( UnifiedFPImpl (GetFP, GetFPRoundingMode), + ) +import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) + +instance + (ValidFP eb0 sb0, ValidFP eb1 sb1) => + UnifiedFPFPConversionImpl + 'C + FP + eb0 + sb0 + eb1 + sb1 + (FP eb0 sb0) + (FP eb1 sb1) + FPRoundingMode + +instance + (ValidFP eb0 sb0, ValidFP eb1 sb1) => + UnifiedFPFPConversionImpl + 'S + SymFP + eb0 + sb0 + eb1 + sb1 + (SymFP eb0 sb0) + (SymFP eb1 sb1) + SymFPRoundingMode + +instance + ( UnifiedFPFPConversionImpl + (mode :: EvalModeTag) + (GetFP mode) + eb0 + sb0 + eb1 + sb1 + (GetFP mode eb0 sb0) + (GetFP mode eb1 sb1) + (GetFPRoundingMode mode) + ) => + UnifiedFPFPConversion mode eb0 sb0 eb1 sb1 + +instance + ( forall eb0 sb0 eb1 sb1. + (ValidFP eb0 sb0, ValidFP eb1 sb1) => + UnifiedFPFPConversion + mode + eb0 + sb0 + eb1 + sb1 + ) => + AllUnifiedFPFPConversion mode diff --git a/src/Grisette/Internal/Internal/Impl/Unified/UnifiedBV.hs b/src/Grisette/Internal/Internal/Impl/Unified/UnifiedBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/UnifiedBV.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.UnifiedBV +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.UnifiedBV () where + +import Control.Exception (ArithException) +import Control.Monad.Except (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.BitVector (SizedBV) +import Grisette.Internal.Internal.Decl.Unified.UnifiedBV + ( AllUnifiedBV, + GetSomeIntN, + GetSomeWordN, + SafeUnifiedBV, + SafeUnifiedBVImpl, + SafeUnifiedSomeBV, + SafeUnifiedSomeBVImpl, + SomeBVPair, + UnifiedBV, + UnifiedBVImpl (GetIntN, GetWordN), + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBV, + SomeBVException, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv) +import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith + ( UnifiedSafeLinearArith, + ) +import Grisette.Internal.Unified.Class.UnifiedSafeSymRotate + ( UnifiedSafeSymRotate, + ) +import Grisette.Internal.Unified.Class.UnifiedSafeSymShift (UnifiedSafeSymShift) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) + +instance + (KnownNat n, 1 <= n) => + UnifiedBVImpl 'C WordN IntN n (WordN n) (IntN n) + where + type GetWordN 'C = WordN + type GetIntN 'C = IntN + +instance + (KnownNat n, 1 <= n) => + UnifiedBVImpl 'S SymWordN SymIntN n (SymWordN n) (SymIntN n) + where + type GetWordN 'S = SymWordN + type GetIntN 'S = SymIntN + +instance + ( UnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + ) => + UnifiedBV mode n + +instance + ( UnifiedSafeDiv mode ArithException word m, + UnifiedSafeLinearArith mode ArithException word m, + UnifiedSafeSymShift mode ArithException word m, + UnifiedSafeSymRotate mode ArithException word m, + UnifiedSafeDiv mode ArithException int m, + UnifiedSafeLinearArith mode ArithException int m, + UnifiedSafeSymShift mode ArithException int m, + UnifiedSafeSymRotate mode ArithException int m, + UnifiedBVImpl mode wordn intn n word int + ) => + SafeUnifiedBVImpl mode wordn intn n word int m + +instance + ( SafeUnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + m + ) => + SafeUnifiedBV mode n m + +instance + ( SomeBVPair mode word int, + UnifiedSafeDiv mode (Either SomeBVException ArithException) word m, + UnifiedSafeLinearArith mode (Either SomeBVException ArithException) word m, + UnifiedSafeSymRotate mode (Either SomeBVException ArithException) word m, + UnifiedSafeSymShift mode (Either SomeBVException ArithException) word m, + UnifiedSafeDiv mode (Either SomeBVException ArithException) int m, + UnifiedSafeLinearArith mode (Either SomeBVException ArithException) int m, + UnifiedSafeSymRotate mode (Either SomeBVException ArithException) int m, + UnifiedSafeSymShift mode (Either SomeBVException ArithException) int m + ) => + SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m + +instance + ( SafeUnifiedSomeBVImpl + mode + (SomeBV (GetWordN mode)) + (SomeBV (GetIntN mode)) + m + ) => + SafeUnifiedSomeBV mode m + +instance + ( forall n m. + ( UnifiedBranching mode m, + MonadError ArithException m, + KnownNat n, + 1 <= n + ) => + SafeUnifiedBV mode n m, + forall m. + ( UnifiedBranching mode m, + MonadError (Either SomeBVException ArithException) m + ) => + SafeUnifiedSomeBV mode m, + forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n, + SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode), + SizedBV (GetWordN mode), + SizedBV (GetIntN mode) + ) => + AllUnifiedBV mode diff --git a/src/Grisette/Internal/Internal/Impl/Unified/UnifiedBool.hs b/src/Grisette/Internal/Internal/Impl/Unified/UnifiedBool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/UnifiedBool.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.UnifiedBool +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.UnifiedBool () where + +import Grisette.Internal.Internal.Decl.Unified.UnifiedBool + ( UnifiedBool (GetBool), + ) +import Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd () +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) + +instance UnifiedBool 'C where + type GetBool 'C = Bool + +instance UnifiedBool 'S where + type GetBool 'S = SymBool diff --git a/src/Grisette/Internal/Internal/Impl/Unified/UnifiedFP.hs b/src/Grisette/Internal/Internal/Impl/Unified/UnifiedFP.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Internal/Impl/Unified/UnifiedFP.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Internal.Impl.Unified.UnifiedFP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Internal.Impl.Unified.UnifiedFP () where + +import Control.Monad.Error.Class (MonadError) +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP + ( AllUnifiedFP, + GetFP, + GetFPRoundingMode, + SafeUnifiedFP, + SafeUnifiedFPImpl, + UnifiedFP, + UnifiedFPImpl, + ) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.UnifiedInteger (GetInteger) + +instance + (ValidFP eb sb) => + UnifiedFPImpl 'C FP eb sb (FP eb sb) FPRoundingMode + where + type GetFP 'C = FP + type GetFPRoundingMode 'C = FPRoundingMode + +instance + (ValidFP eb sb) => + UnifiedFPImpl 'S SymFP eb sb (SymFP eb sb) SymFPRoundingMode + where + type GetFP 'S = SymFP + type GetFPRoundingMode 'S = SymFPRoundingMode + +instance + ( UnifiedFPImpl + mode + (GetFP mode) + eb + sb + (GetFP mode eb sb) + (GetFPRoundingMode mode) + ) => + UnifiedFP mode eb sb + +instance + (UnifiedFPImpl mode fpn eb sb fp rd) => + SafeUnifiedFPImpl mode fpn eb sb fp rd m + +instance + ( SafeUnifiedFPImpl + mode + (GetFP mode) + eb + sb + (GetFP mode eb sb) + (GetFPRoundingMode mode) + m, + UnifiedSafeFromFP + mode + NotRepresentableFPError + (GetInteger mode) + (GetFP mode eb sb) + (GetFPRoundingMode mode) + m + ) => + SafeUnifiedFP mode eb sb m + +instance + ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb, + forall eb sb m. + ( ValidFP eb sb, + UnifiedBranching mode m, + MonadError NotRepresentableFPError m + ) => + SafeUnifiedFP mode eb sb m + ) => + AllUnifiedFP mode diff --git a/src/Grisette/Internal/SymPrim/AllSyms.hs b/src/Grisette/Internal/SymPrim/AllSyms.hs --- a/src/Grisette/Internal/SymPrim/AllSyms.hs +++ b/src/Grisette/Internal/SymPrim/AllSyms.hs @@ -1,21 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Internal.SymPrim.AllSyms @@ -45,430 +28,5 @@ ) 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.Kind (Type) -import Data.Ratio (Ratio, denominator, numerator) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( Generic (Rep, from), - Generic1 (Rep1, from1), - K1 (K1), - M1 (M1), - Par1 (Par1), - Rec1 (Rec1), - U1, - V1, - (:.:) (Comp1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Default1 (Default1, unDefault1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.Prim.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep (underlyingTerm), - pformatTerm, - ) -import Grisette.Internal.SymPrim.Prim.TermUtils - ( someTermsSize, - termSize, - termsSize, - ) -import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (ViaDefault, ViaDefault1), - ) -import Grisette.Internal.Utils.Derive (Arity0, Arity1) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Grisette.Backend --- >>> import Data.Proxy - --- | Some symbolic value with 'LinkedRep' constraint. -data SomeSym where - SomeSym :: (LinkedRep con sym) => sym -> SomeSym - -instance Show SomeSym where - show (SomeSym s) = pformatTerm $ underlyingTerm s - --- | Extract all symbolic primitive values that are represented as SMT terms. --- --- >>> allSyms (["a" + 1 :: SymInteger, -"b"], "c" :: SymBool) --- [(+ 1 a),(- b),c] --- --- This is usually used for getting a statistical summary of the size of --- a symbolic value with 'allSymsSize'. --- --- __Note:__ This type class can be derived for algebraic data types. You may --- need the @DerivingVia@ and @DerivingStrategies@ extenstions. --- --- > data X = ... deriving Generic deriving AllSyms via (Default X) -class AllSyms a where - -- | Convert a value to a list of symbolic primitive values. It should - -- prepend to an existing list of symbolic primitive values. - allSymsS :: a -> [SomeSym] -> [SomeSym] - allSymsS a l = allSyms a ++ l - - -- | Specialized 'allSymsS' that prepends to an empty list. - allSyms :: a -> [SomeSym] - allSyms a = allSymsS a [] - - {-# MINIMAL allSymsS | allSyms #-} - --- | Get the sum of the sizes of a list of symbolic terms. --- Duplicate sub-terms are counted for only once. --- --- >>> symsSize [1, "a" :: SymInteger, "a" + 1 :: SymInteger] --- 3 -symsSize :: forall con sym. (LinkedRep con sym) => [sym] -> Int -symsSize = termsSize . fmap (underlyingTerm @con) -{-# INLINE symsSize #-} - --- | Get the size of a symbolic term. --- Duplicate sub-terms are counted for only once. --- --- >>> symSize (1 :: SymInteger) --- 1 --- >>> symSize ("a" :: SymInteger) --- 1 --- >>> symSize ("a" + 1 :: SymInteger) --- 3 --- >>> symSize (("a" + 1) * ("a" + 1) :: SymInteger) --- 4 -symSize :: forall con sym. (LinkedRep con sym) => sym -> Int -symSize = termSize . underlyingTerm @con -{-# INLINE symSize #-} - -someUnderlyingTerm :: SomeSym -> SomeTerm -someUnderlyingTerm (SomeSym s) = SomeTerm $ underlyingTerm s - -someSymsSize :: [SomeSym] -> Int -someSymsSize = someTermsSize . fmap someUnderlyingTerm -{-# INLINE someSymsSize #-} - --- | Get the total size of symbolic terms in a value. --- Duplicate sub-terms are counted for only once. --- --- >>> allSymsSize ("a" :: SymInteger, "a" + "b" :: SymInteger, ("a" + "b") * "c" :: SymInteger) --- 5 --- --- The 5 terms are @a@, @b@, @(+ a b)@, @c@, and @(* (+ a b) c)@. -allSymsSize :: (AllSyms a) => a -> Int -allSymsSize = someSymsSize . allSyms - --- | Lifting of the 'AllSyms' class to unary type constructors. -class (forall a. (AllSyms a) => AllSyms (f a)) => AllSyms1 f where - -- | Lift the 'allSymsS' function to unary type constructors. - liftAllSymsS :: (a -> [SomeSym] -> [SomeSym]) -> f a -> [SomeSym] -> [SomeSym] - --- | Lift the standard 'allSymsS' function to unary type constructors. -allSymsS1 :: (AllSyms1 f, AllSyms a) => f a -> [SomeSym] -> [SomeSym] -allSymsS1 = liftAllSymsS allSymsS -{-# INLINE allSymsS1 #-} - --- | Lifting of the 'AllSyms' class to binary type constructors. -class (forall a. (AllSyms a) => AllSyms1 (f a)) => AllSyms2 f where - -- | Lift the 'allSymsS' function to binary type constructors. - liftAllSymsS2 :: - (a -> [SomeSym] -> [SomeSym]) -> - (b -> [SomeSym] -> [SomeSym]) -> - f a b -> - [SomeSym] -> - [SomeSym] - --- | Lift the standard 'allSymsS' function to binary type constructors. -allSymsS2 :: - (AllSyms2 f, AllSyms a, AllSyms b) => f a b -> [SomeSym] -> [SomeSym] -allSymsS2 = liftAllSymsS2 allSymsS allSymsS -{-# INLINE allSymsS2 #-} - --- Derivation - --- | The arguments to the generic 'AllSyms' function. -data family AllSymsArgs arity a :: Type - -data instance AllSymsArgs Arity0 _ = AllSymsArgs0 - -newtype instance AllSymsArgs Arity1 a - = AllSymsArgs1 (a -> [SomeSym] -> [SomeSym]) - --- | The class of types that can generically extract all symbolic primitives. -class GAllSyms arity f where - gallSymsS :: AllSymsArgs arity a -> f a -> [SomeSym] -> [SomeSym] - -instance GAllSyms arity V1 where - gallSymsS _ _ = id - -instance GAllSyms arity U1 where - gallSymsS _ _ = id - -instance (AllSyms c) => GAllSyms arity (K1 i c) where - gallSymsS _ (K1 x) = allSymsS x - -instance (GAllSyms arity a) => GAllSyms arity (M1 i c a) where - gallSymsS args (M1 x) = gallSymsS args x - -instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :+: b) where - gallSymsS args (L1 l) = gallSymsS args l - gallSymsS args (R1 r) = gallSymsS args r - -instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :*: b) where - gallSymsS args (a :*: b) = gallSymsS args a . gallSymsS args b - -instance GAllSyms Arity1 Par1 where - gallSymsS (AllSymsArgs1 f) (Par1 x) = f x - -instance (AllSyms1 f) => GAllSyms Arity1 (Rec1 f) where - gallSymsS (AllSymsArgs1 f) (Rec1 x) = liftAllSymsS f x - -instance (AllSyms1 f, GAllSyms Arity1 g) => GAllSyms Arity1 (f :.: g) where - gallSymsS targs (Comp1 x) = liftAllSymsS (gallSymsS targs) x - --- | Generic 'allSymsS' function. -genericAllSymsS :: - (Generic a, GAllSyms Arity0 (Rep a)) => - a -> - [SomeSym] -> - [SomeSym] -genericAllSymsS x = gallSymsS AllSymsArgs0 (from x) -{-# INLINE genericAllSymsS #-} - --- | Generic 'liftAllSymsS' function. -genericLiftAllSymsS :: - (Generic1 f, GAllSyms Arity1 (Rep1 f)) => - (a -> [SomeSym] -> [SomeSym]) -> - f a -> - [SomeSym] -> - [SomeSym] -genericLiftAllSymsS f x = gallSymsS (AllSymsArgs1 f) (from1 x) -{-# INLINE genericLiftAllSymsS #-} - -instance (Generic a, GAllSyms Arity0 (Rep a)) => AllSyms (Default a) where - allSymsS = genericAllSymsS . unDefault - {-# INLINE allSymsS #-} - -instance - (Generic1 f, GAllSyms Arity1 (Rep1 f), AllSyms a) => - AllSyms (Default1 f a) - where - allSymsS = allSymsS1 - {-# INLINE allSymsS #-} - -instance (Generic1 f, GAllSyms Arity1 (Rep1 f)) => AllSyms1 (Default1 f) where - liftAllSymsS f = genericLiftAllSymsS f . unDefault1 - {-# INLINE liftAllSymsS #-} - --- Instances -deriveBuiltins - (ViaDefault ''AllSyms) - [''AllSyms] - [ ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''Identity - ] - -deriveBuiltins - (ViaDefault1 ''AllSyms1) - [''AllSyms, ''AllSyms1] - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity - ] - --- ExceptT -instance - (AllSyms1 m, AllSyms e, AllSyms a) => - AllSyms (ExceptT e m a) - where - allSymsS = allSymsS1 - {-# INLINE allSymsS #-} - -instance - (AllSyms1 m, AllSyms e) => - AllSyms1 (ExceptT e m) - where - liftAllSymsS f (ExceptT v) = liftAllSymsS (liftAllSymsS f) v - {-# INLINE liftAllSymsS #-} - --- MaybeT -instance (AllSyms1 m, AllSyms a) => AllSyms (MaybeT m a) where - allSymsS = allSymsS1 - {-# INLINE allSymsS #-} - -instance (AllSyms1 m) => AllSyms1 (MaybeT m) where - liftAllSymsS f (MaybeT v) = liftAllSymsS (liftAllSymsS f) v - {-# INLINE liftAllSymsS #-} - --- WriterT -instance - (AllSyms1 m, AllSyms a, AllSyms s) => - AllSyms (WriterLazy.WriterT s m a) - where - allSymsS = allSymsS1 - {-# INLINE allSymsS #-} - -instance - (AllSyms1 m, AllSyms s) => - AllSyms1 (WriterLazy.WriterT s m) - where - liftAllSymsS f (WriterLazy.WriterT v) = - liftAllSymsS (liftAllSymsS2 f allSymsS) v - {-# INLINE liftAllSymsS #-} - -instance - (AllSyms1 m, AllSyms a, AllSyms s) => - AllSyms (WriterStrict.WriterT s m a) - where - allSymsS = allSymsS1 - {-# INLINE allSymsS #-} - -instance - (AllSyms1 m, AllSyms s) => - AllSyms1 (WriterStrict.WriterT s m) - where - liftAllSymsS f (WriterStrict.WriterT v) = - liftAllSymsS (liftAllSymsS2 f allSymsS) v - {-# INLINE liftAllSymsS #-} - --- Sum -deriving via - (Default (Sum f g a)) - instance - (AllSyms (f a), AllSyms (g a)) => - AllSyms (Sum f g a) - -deriving via - (Default1 (Sum f g)) - instance - (AllSyms1 f, AllSyms1 g) => - AllSyms1 (Sum f g) - --- IdentityT -instance - (AllSyms1 m, AllSyms a) => - AllSyms (IdentityT m a) - where - allSymsS = allSymsS1 - {-# INLINE allSymsS #-} - -instance (AllSyms1 m) => AllSyms1 (IdentityT m) where - liftAllSymsS f (IdentityT a) = liftAllSymsS f a - {-# INLINE liftAllSymsS #-} - --- AllSyms2 -instance AllSyms2 Either where - liftAllSymsS2 f _ (Left x) = f x - liftAllSymsS2 _ g (Right y) = g y - {-# INLINE liftAllSymsS2 #-} - -instance AllSyms2 (,) where - liftAllSymsS2 f g (x, y) = f x . g y - {-# INLINE liftAllSymsS2 #-} - -instance (AllSyms a) => AllSyms2 ((,,) a) where - liftAllSymsS2 f g (x, y, z) = allSymsS x . f y . g z - {-# INLINE liftAllSymsS2 #-} - -instance (AllSyms a, AllSyms b) => AllSyms2 ((,,,) a b) where - liftAllSymsS2 f g (x, y, z, w) = allSymsS x . allSymsS y . f z . g w - {-# INLINE liftAllSymsS2 #-} - -#define CONCRETE_ALLSYMS(type) \ -instance AllSyms type where \ - allSymsS _ = id; \ - {-# INLINE allSymsS #-} - -#define CONCRETE_ALLSYMS_BV(type) \ -instance (KnownNat n, 1 <= n) => AllSyms (type n) where \ - allSymsS _ = id; \ - {-# INLINE allSymsS #-} - -#if 1 -CONCRETE_ALLSYMS(Bool) -CONCRETE_ALLSYMS(Integer) -CONCRETE_ALLSYMS(Char) -CONCRETE_ALLSYMS(Int) -CONCRETE_ALLSYMS(Int8) -CONCRETE_ALLSYMS(Int16) -CONCRETE_ALLSYMS(Int32) -CONCRETE_ALLSYMS(Int64) -CONCRETE_ALLSYMS(Word) -CONCRETE_ALLSYMS(Word8) -CONCRETE_ALLSYMS(Word16) -CONCRETE_ALLSYMS(Word32) -CONCRETE_ALLSYMS(Word64) -CONCRETE_ALLSYMS(Float) -CONCRETE_ALLSYMS(Double) -CONCRETE_ALLSYMS(B.ByteString) -CONCRETE_ALLSYMS(T.Text) -CONCRETE_ALLSYMS(FPRoundingMode) -CONCRETE_ALLSYMS_BV(WordN) -CONCRETE_ALLSYMS_BV(IntN) -CONCRETE_ALLSYMS(AlgReal) -#endif - -instance (AllSyms a) => AllSyms (Ratio a) where - allSymsS r = allSymsS (numerator r) . allSymsS (denominator r) - {-# INLINE allSymsS #-} - -instance (ValidFP eb sb) => AllSyms (FP eb sb) where - allSymsS _ = id - {-# INLINE allSymsS #-} +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms +import Grisette.Internal.Internal.Impl.SymPrim.AllSyms () diff --git a/src/Grisette/Internal/SymPrim/BV.hs b/src/Grisette/Internal/SymPrim/BV.hs --- a/src/Grisette/Internal/SymPrim/BV.hs +++ b/src/Grisette/Internal/SymPrim/BV.hs @@ -36,6 +36,7 @@ WordN16, WordN32, WordN64, + readBinary, ) where @@ -194,6 +195,7 @@ | Just i <- L.numberToInteger n = return (fromInteger i) convertInt _ = pfail +-- | Read a binary number. readBinary :: (Num a) => ReadPrec a readBinary = parens $ do r0 <- look @@ -212,8 +214,16 @@ _ <- Text.Read.lift $ string "0b" fromInteger <$> Text.Read.lift (L.readIntP 2 isDigit valDigit) +#if MIN_VERSION_base(4,21,0) +readBV :: Num a => ReadPrec a +readBV = readNumber convertInt +#else +readBV :: Num a => ReadPrec a +readBV = readNumber convertInt <|> readBinary +#endif + instance (KnownNat n, 1 <= n) => Read (WordN n) where - readPrec = readNumber convertInt <|> readBinary + readPrec = readBV readListPrec = readListPrecDefault readList = readListDefault @@ -269,7 +279,7 @@ get = deserialize instance (KnownNat n, 1 <= n) => Read (IntN n) where - readPrec = readNumber convertInt <|> readBinary + readPrec = readBV readListPrec = readListPrecDefault readList = readListDefault diff --git a/src/Grisette/Internal/SymPrim/GeneralFun.hs b/src/Grisette/Internal/SymPrim/GeneralFun.hs --- a/src/Grisette/Internal/SymPrim/GeneralFun.hs +++ b/src/Grisette/Internal/SymPrim/GeneralFun.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# HLINT ignore "Eta reduce" #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -35,9 +36,14 @@ ) where +#if MIN_VERSION_base(4,20,0) +import Data.Foldable (Foldable (toList)) +#else +import Data.Foldable (Foldable (foldl', toList)) +#endif + import Control.DeepSeq (NFData (rnf)) import Data.Bifunctor (Bifunctor (second)) -import Data.Foldable (Foldable (foldl', toList)) import qualified Data.HashSet as HS import Data.Hashable (Hashable (hashWithSalt)) import Data.List.NonEmpty (NonEmpty ((:|))) diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs @@ -23,7 +23,6 @@ where import Control.Monad (msum) -import Data.Foldable (Foldable (foldl')) import qualified Data.SBV as SBV import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.SymPrim.AlgReal (AlgReal) @@ -158,7 +157,7 @@ SBV.SRoundingMode -> SBV.SBV Bool sbvTableLookup tbl lhs rhs = - foldl' + foldl (\acc (a, b) -> acc SBV..|| ((lhs SBV..== a) SBV..&& (rhs SBV..== b))) SBV.sFalse tbl diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs @@ -23,7 +23,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -209,7 +209,7 @@ ) #endif -#if !MIN_VERSION_sbv(10, 0, 0) +#if !MIN_VERSION_sbv(10,0,0) #define SMTDefinable Uninterpreted #endif @@ -217,6 +217,12 @@ import qualified Data.SBV as SBVTC #endif +#if MIN_VERSION_base(4,15,0) +import Language.Haskell.TH (Code, Quote) +#else +import Language.Haskell.TH (TExpQ) +#endif + import Control.DeepSeq (NFData (rnf)) import Control.Monad (msum) import Control.Monad.IO.Class (MonadIO) @@ -1931,6 +1937,12 @@ rnf i = rnf (termId i) `seq` rnf (termIdent i) {-# INLINE rnf #-} +#if MIN_VERSION_base(4,15,0) +type CODE x = forall qq. Quote qq => Code qq (x) +#else +type CODE x = TExpQ x +#endif + instance Lift (Term t) where liftTyped (ConTerm _ _ _ _ v) = [||conTerm v||] liftTyped (SymTerm _ _ _ _ t) = [||symTerm t||] @@ -1961,9 +1973,12 @@ liftTyped (BitCastOrTerm _ _ _ _ t1 t2) = [||bitCastOrTerm t1 t2||] liftTyped (BVConcatTerm _ _ _ _ t1 t2) = [||bvConcatTerm t1 t2||] liftTyped (BVSelectTerm _ _ _ _ (_ :: p ix) (_ :: q w) t3) = - [||bvSelectTerm (Proxy @ix) (Proxy @w) t3||] + let pix = [||Proxy||] :: CODE (Proxy ix) + pw = [||Proxy||] :: CODE (Proxy w) + in [||bvSelectTerm $$pix $$pw t3||] liftTyped (BVExtendTerm _ _ _ _ b (_ :: p r) t2) = - [||bvExtendTerm b (Proxy @r) t2||] + let pr = [||Proxy||] :: CODE (Proxy r) + in [||bvExtendTerm b $$pr t2||] liftTyped (ApplyTerm _ _ _ _ t1 t2) = [||applyTerm t1 t2||] liftTyped (DivIntegralTerm _ _ _ _ t1 t2) = [||divIntegralTerm t1 t2||] liftTyped (ModIntegralTerm _ _ _ _ t1 t2) = [||modIntegralTerm t1 t2||] diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs @@ -129,7 +129,11 @@ #if MIN_VERSION_base(4,19,0) weakThreadId = fromThreadId #else +#if __GLASGOW_HASKELL__ >= 904 +weakThreadId (ThreadId t#) = rts_getThreadId (threadIdToAddr# t#) +#else weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#) +#endif foreign import ccall unsafe "rts_getThreadId" #if __GLASGOW_HASKELL__ >= 904 diff --git a/src/Grisette/Internal/SymPrim/SymAlgReal.hs b/src/Grisette/Internal/SymPrim/SymAlgReal.hs --- a/src/Grisette/Internal/SymPrim/SymAlgReal.hs +++ b/src/Grisette/Internal/SymPrim/SymAlgReal.hs @@ -26,8 +26,11 @@ import Grisette.Internal.Core.Data.Class.Solvable ( Solvable (con, conView, ssym, sym), ) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) import Grisette.Internal.SymPrim.Prim.Internal.Term ( FloatingUnaryOp ( FloatingAcos, diff --git a/src/Grisette/Internal/SymPrim/SymBV.hs b/src/Grisette/Internal/SymPrim/SymBV.hs --- a/src/Grisette/Internal/SymPrim/SymBV.hs +++ b/src/Grisette/Internal/SymPrim/SymBV.hs @@ -98,7 +98,10 @@ import Grisette.Internal.Core.Data.Class.SymShift ( SymShift (symShift, symShiftNegated), ) -import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.BV ( IntN, WordN, diff --git a/src/Grisette/Internal/SymPrim/SymBool.hs b/src/Grisette/Internal/SymPrim/SymBool.hs --- a/src/Grisette/Internal/SymPrim/SymBool.hs +++ b/src/Grisette/Internal/SymPrim/SymBool.hs @@ -25,7 +25,10 @@ import Grisette.Internal.Core.Data.Class.Solvable ( Solvable (con, conView, ssym, sym), ) -import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.Prim.Internal.Term ( ConRep (ConType), LinkedRep (underlyingTerm, wrapTerm), diff --git a/src/Grisette/Internal/SymPrim/SymFP.hs b/src/Grisette/Internal/SymPrim/SymFP.hs --- a/src/Grisette/Internal/SymPrim/SymFP.hs +++ b/src/Grisette/Internal/SymPrim/SymFP.hs @@ -96,7 +96,10 @@ symFpIsZero ), ) -import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.FP ( FP, diff --git a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs --- a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs +++ b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs @@ -41,7 +41,10 @@ import Grisette.Internal.Core.Data.Class.Solvable ( Solvable (con, conView, ssym, sym), ) -import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.GeneralFun (buildGeneralFun, type (-->)) import Grisette.Internal.SymPrim.Prim.Term ( ConRep (ConType), diff --git a/src/Grisette/Internal/SymPrim/SymInteger.hs b/src/Grisette/Internal/SymPrim/SymInteger.hs --- a/src/Grisette/Internal/SymPrim/SymInteger.hs +++ b/src/Grisette/Internal/SymPrim/SymInteger.hs @@ -22,8 +22,13 @@ 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.Core.Data.Class.Solvable + ( Solvable (con, conView, ssym, sym), + ) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.Prim.Term ( ConRep (ConType), LinkedRep (underlyingTerm, wrapTerm), diff --git a/src/Grisette/Internal/SymPrim/SymPrim.hs b/src/Grisette/Internal/SymPrim/SymPrim.hs --- a/src/Grisette/Internal/SymPrim/SymPrim.hs +++ b/src/Grisette/Internal/SymPrim/SymPrim.hs @@ -23,14 +23,14 @@ import Grisette.Internal.Core.Data.Class.GenSym (GenSymSimple) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.PPrint (PPrint) import Grisette.Internal.Core.Data.Class.SimpleMergeable (SimpleMergeable) import Grisette.Internal.Core.Data.Class.Solvable (Solvable) import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) -import Grisette.Internal.Core.Data.Class.SymEq (SymEq) -import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) import Grisette.Internal.Core.Data.Class.ToCon (ToCon) import Grisette.Internal.Core.Data.Class.ToSym (ToSym) +import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq (SymEq) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd (SymOrd) import Grisette.Internal.SymPrim.AllSyms (AllSyms) import Grisette.Internal.SymPrim.Prim.Internal.Term ( ConRep (ConType), diff --git a/src/Grisette/Internal/SymPrim/SymTabularFun.hs b/src/Grisette/Internal/SymPrim/SymTabularFun.hs --- a/src/Grisette/Internal/SymPrim/SymTabularFun.hs +++ b/src/Grisette/Internal/SymPrim/SymTabularFun.hs @@ -36,7 +36,10 @@ import Grisette.Internal.Core.Data.Class.Solvable ( Solvable (con, conView, ssym, sym), ) -import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) import Grisette.Internal.SymPrim.Prim.Term ( ConRep (ConType), LinkedRep (underlyingTerm, wrapTerm), diff --git a/src/Grisette/Internal/TH/Ctor/Common.hs b/src/Grisette/Internal/TH/Ctor/Common.hs --- a/src/Grisette/Internal/TH/Ctor/Common.hs +++ b/src/Grisette/Internal/TH/Ctor/Common.hs @@ -16,8 +16,7 @@ import Control.Monad (unless) import Data.Char (isAlphaNum, toLower) import Data.Foldable (traverse_) -import Grisette.Internal.TH.Util (occName) -import Language.Haskell.TH (Dec, Name, Q) +import Language.Haskell.TH (Dec, Name, Q, nameBase) import Language.Haskell.TH.Datatype ( ConstructorInfo (constructorName), DatatypeInfo (datatypeCons), @@ -46,7 +45,7 @@ Q [Dec] withNameTransformer namedGen nameTransformer typName = do d <- reifyDatatype typName - let constructorNames = occName . constructorName <$> datatypeCons d + let constructorNames = nameBase . constructorName <$> datatypeCons d let transformedNames = nameTransformer <$> constructorNames traverse_ checkName transformedNames namedGen transformedNames typName diff --git a/src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs b/src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs --- a/src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs +++ b/src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs @@ -17,19 +17,22 @@ where import Control.Monad (join, replicateM, when, zipWithM) +import Data.Maybe (catMaybes) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1, Mergeable2) import Grisette.Internal.TH.Ctor.Common ( decapitalizeTransformer, prefixTransformer, withNameTransformer, ) -import Grisette.Internal.TH.Util (constructorInfoToType, putHaddock) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag) -import Grisette.Unified.Internal.UnifiedData +import Grisette.Internal.TH.GADT.Common (ctxForVar) +import Grisette.Internal.TH.Util (constructorInfoToType, putHaddock, tvIsMode) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) +import Grisette.Internal.Unified.UnifiedData ( GetData, UnifiedData, wrapData, ) -import Language.Haskell.TH (pprint) +import Language.Haskell.TH (conT, pprint, varT) import Language.Haskell.TH.Datatype ( ConstructorInfo (constructorFields, constructorName), DatatypeInfo (datatypeCons, datatypeVars), @@ -62,8 +65,8 @@ -- -- The generated smart constructors will contruct values of type -- @GetData mode (T mode a b c)@. -makeUnifiedCtorWith :: (String -> String) -> Name -> Q [Dec] -makeUnifiedCtorWith = withNameTransformer makeNamedUnifiedCtor +makeUnifiedCtorWith :: [Name] -> (String -> String) -> Name -> Q [Dec] +makeUnifiedCtorWith = withNameTransformer . makeNamedUnifiedCtor -- | Generate smart constructors to create unified values. -- @@ -74,12 +77,14 @@ -- The generated smart constructors will contruct values of type -- @GetData mode (T mode a b c)@. makePrefixedUnifiedCtor :: + [Name] -> -- | Prefix for generated wrappers String -> -- | The type to generate the wrappers for Name -> Q [Dec] -makePrefixedUnifiedCtor = makeUnifiedCtorWith . prefixTransformer +makePrefixedUnifiedCtor modeCtx = + makeUnifiedCtorWith modeCtx . prefixTransformer -- | Generate smart constructors to create unified values. -- @@ -90,10 +95,11 @@ -- The generated smart constructors will contruct values of type -- @GetData mode (T mode a b c)@. makeUnifiedCtor :: + [Name] -> -- | The type to generate the wrappers for Name -> Q [Dec] -makeUnifiedCtor = makeUnifiedCtorWith decapitalizeTransformer +makeUnifiedCtor modeCtx = makeUnifiedCtorWith modeCtx decapitalizeTransformer -- | Generate smart constructors to create unified values. -- @@ -103,12 +109,13 @@ -- The generated smart constructors will contruct values of type -- @GetData mode (T mode a b c)@. makeNamedUnifiedCtor :: + [Name] -> -- | Names for generated wrappers [String] -> -- | The type to generate the wrappers for Name -> Q [Dec] -makeNamedUnifiedCtor names typName = do +makeNamedUnifiedCtor modeCtx names typName = do d <- reifyDatatype typName let constructors = datatypeCons d when (length names /= length constructors) $ @@ -120,7 +127,7 @@ [mode] -> do ds <- zipWithM - (mkSingleWrapper d Nothing $ VarT $ tvName mode) + (mkSingleWrapper modeCtx d Nothing $ VarT $ tvName mode) names constructors return $ join ds @@ -129,7 +136,7 @@ let newBndr = kindedTVSpecified n (ConT ''EvalModeTag) ds <- zipWithM - (mkSingleWrapper d (Just newBndr) (VarT n)) + (mkSingleWrapper modeCtx d (Just newBndr) (VarT n)) names constructors return $ join ds @@ -144,16 +151,49 @@ predu <- [t|UnifiedData $(return mode) $(return t)|] return ([predu], r) -augmentConstructorType :: Maybe TyVarBndrSpec -> Type -> Type -> Q Type -augmentConstructorType modeBndr mode (ForallT tybinders ctx ty1) = do - (preds, augmentedTyp) <- augmentFinalType mode ty1 - case modeBndr of - Just bndr -> return $ ForallT (bndr : tybinders) (preds ++ ctx) augmentedTyp - Nothing -> return $ ForallT tybinders (preds ++ ctx) augmentedTyp -augmentConstructorType modeBndr mode ty = do +augmentConstructorType :: + [Name] -> Maybe TyVarBndrSpec -> Type -> Type -> Q Type +augmentConstructorType + modeCtx + freshModeBndr + mode + (ForallT tybinders ctx ty1) = do + (preds, augmentedTyp) <- augmentFinalType mode ty1 + let modeBndrsInForall = filter tvIsMode tybinders + mergeablePreds <- + catMaybes + <$> traverse + ( \bndr -> + ctxForVar + (ConT <$> [''Mergeable, ''Mergeable1, ''Mergeable2]) + (VarT $ tvName bndr) + (tvKind bndr) + ) + tybinders + modePred <- + case (modeBndrsInForall, freshModeBndr) of + ([bndr], Nothing) -> + traverse (\nm -> [t|$(conT nm) $(varT $ tvName bndr)|]) modeCtx + ([], Just bndr) -> + traverse (\nm -> [t|$(conT nm) $(varT $ tvName bndr)|]) modeCtx + _ -> fail "Unsupported constructor type." + case freshModeBndr of + Just bndr -> do + return $ + ForallT + (bndr : tybinders) + (modePred ++ mergeablePreds ++ preds ++ ctx) + augmentedTyp + Nothing -> + return $ + ForallT + tybinders + (modePred ++ mergeablePreds ++ preds ++ ctx) + augmentedTyp +augmentConstructorType _ freshModeBndr mode ty = do (preds, augmentedTyp) <- augmentFinalType mode ty - case modeBndr of - Just bndr -> return $ ForallT [bndr] preds augmentedTyp + case freshModeBndr of + Just bndr -> return $ ForallT [bndr] (preds) augmentedTyp Nothing -> fail $ "augmentConstructorType: unsupported constructor type: " ++ pprint ty @@ -170,10 +210,18 @@ ) ) -mkSingleWrapper :: DatatypeInfo -> Maybe TyVarBndrSpec -> Type -> String -> ConstructorInfo -> Q [Dec] -mkSingleWrapper dataType modeBndr mode name info = do +mkSingleWrapper :: + [Name] -> + DatatypeInfo -> + Maybe TyVarBndrSpec -> + Type -> + String -> + ConstructorInfo -> + Q [Dec] +mkSingleWrapper modeCtx dataType freshModeBndr mode name info = do constructorTyp <- constructorInfoToType dataType info - augmentedTyp <- augmentConstructorType modeBndr mode constructorTyp + augmentedTyp <- + augmentConstructorType modeCtx freshModeBndr mode constructorTyp let oriName = constructorName info let retName = mkName name expr <- augmentExpr mode (length $ constructorFields info) (ConE oriName) diff --git a/src/Grisette/Internal/TH/DeriveBuiltin.hs b/src/Grisette/Internal/TH/DeriveBuiltin.hs deleted file mode 100644 --- a/src/Grisette/Internal/TH/DeriveBuiltin.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | --- Module : Grisette.Internal.TH.DeriveBuiltin --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.TH.DeriveBuiltin - ( deriveBuiltinExtra, - deriveBuiltin, - deriveBuiltins, - ) -where - -import Control.Monad (when) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (strategyClassName), - ) -import Grisette.Internal.TH.DeriveTypeParamHandler - ( NatShouldBePositive (NatShouldBePositive), - PrimaryConstraint (PrimaryConstraint), - SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler), - ) -import Grisette.Internal.TH.DeriveWithHandlers - ( deriveWithHandlers, - ) -import Grisette.Internal.TH.Util - ( classNumParam, - classParamKinds, - kindNumParam, - ) -import Language.Haskell.TH (Dec, Name, Q) - --- | Derive a builtin class for a type, with extra handlers. -deriveBuiltinExtra :: - [SomeDeriveTypeParamHandler] -> - Maybe [SomeDeriveTypeParamHandler] -> - Bool -> - Strategy -> - [Name] -> - Name -> - Q [Dec] -deriveBuiltinExtra - extraHandlers - replacedHandlers - ignoreBodyConstraints - strategy - constraints - name = do - let finalCtxName = strategyClassName strategy - numParam <- classNumParam finalCtxName - when (numParam == 0) $ - fail "deriveBuiltin: the class must have at least one parameter" - kinds <- classParamKinds finalCtxName - case kinds of - [] -> - fail $ - "deriveBuiltin: the class must have at least one parameter, bug, " - <> "should not happen" - (k : ks) -> do - when (any (/= k) ks) $ - fail "deriveBuiltin: all parameters must have the same kind" - constraintNumParams <- mapM classNumParam constraints - when (any (/= numParam) constraintNumParams) $ - fail $ - "deriveBuiltin: all constraints must have the same number of " - <> "parameters as the results" - numDrop <- kindNumParam k - deriveWithHandlers - ( extraHandlers ++ case replacedHandlers of - Just handlers -> handlers - Nothing -> - SomeDeriveTypeParamHandler NatShouldBePositive - : ( (SomeDeriveTypeParamHandler . flip PrimaryConstraint False) - <$> constraints - ) - ) - strategy - ignoreBodyConstraints - numDrop - (replicate numParam name) - --- | Derive a builtin class for a type. -deriveBuiltin :: Strategy -> [Name] -> Name -> Q [Dec] -deriveBuiltin = deriveBuiltinExtra [] Nothing True - --- | Derive builtin classes for a list of types. -deriveBuiltins :: Strategy -> [Name] -> [Name] -> Q [Dec] -deriveBuiltins strategy constraints = - fmap concat . traverse (deriveBuiltin strategy constraints) diff --git a/src/Grisette/Internal/TH/DeriveInstanceProvider.hs b/src/Grisette/Internal/TH/DeriveInstanceProvider.hs deleted file mode 100644 --- a/src/Grisette/Internal/TH/DeriveInstanceProvider.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | --- Module : Grisette.Internal.TH.DeriveInstanceProvider --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.TH.DeriveInstanceProvider - ( DeriveInstanceProvider (..), - Strategy (..), - ) -where - -import Generics.Deriving (Default, Default1) -import Language.Haskell.TH - ( Dec, - DerivStrategy - ( AnyclassStrategy, - NewtypeStrategy, - StockStrategy, - ViaStrategy - ), - Name, - Pred, - Q, - Type, - appT, - conT, - standaloneDerivWithStrategyD, - ) -import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit) - --- | A derive instance provider provides the instance declaration. -class DeriveInstanceProvider provider where - instanceDeclaration :: - provider -> [[(TyVarBndrUnit, Maybe Type)]] -> [Pred] -> [Type] -> Q [Dec] - --- | A strategy for deriving instances. -data Strategy - = Stock {strategyClassName :: Name} - | WithNewtype {strategyClassName :: Name} - | ViaDefault {strategyClassName :: Name} - | ViaDefault1 {strategyClassName :: Name} - | Anyclass {strategyClassName :: Name} - deriving (Eq) - -getStrategy :: Strategy -> Type -> Q DerivStrategy -getStrategy strategy ty = - case strategy of - Stock _ -> return StockStrategy - WithNewtype _ -> return NewtypeStrategy - ViaDefault _ -> - ViaStrategy - <$> [t|Default $(return ty)|] - ViaDefault1 _ -> - ViaStrategy - <$> [t|Default1 $(return ty)|] - Anyclass _ -> return AnyclassStrategy - -instance DeriveInstanceProvider Strategy where - instanceDeclaration strategy _ preds tys = do - s <- getStrategy strategy (last tys) - (: []) - <$> standaloneDerivWithStrategyD - (Just s) - (return preds) - (foldl appT (conT $ strategyClassName strategy) $ return <$> tys) diff --git a/src/Grisette/Internal/TH/DerivePredefined.hs b/src/Grisette/Internal/TH/DerivePredefined.hs deleted file mode 100644 --- a/src/Grisette/Internal/TH/DerivePredefined.hs +++ /dev/null @@ -1,372 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Unused LANGUAGE pragma" #-} - --- | --- Module : Grisette.Internal.TH.DerivePredefined --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.TH.DerivePredefined - ( derivePredefined, - derivePredefinedMultipleClasses, - derive, - deriveAll, - deriveAllExcept, - ) -where - -#if MIN_VERSION_template_haskell(2,17,0) -import Language.Haskell.TH (Type (MulArrowT)) -#endif -#if MIN_VERSION_template_haskell(2,19,0) -import Language.Haskell.TH (Type (PromotedInfixT, PromotedUInfixT)) -#endif - -import Control.DeepSeq (NFData, NFData1) -import Data.Bytes.Serial (Serial) -import Data.Functor.Classes (Eq1, Ord1, Show1) -import Data.Hashable (Hashable) -import Data.Hashable.Lifted (Hashable1) -import Data.List (nub) -import GHC.Generics (Generic) -import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym, EvalSym1) -import Grisette.Internal.Core.Data.Class.ExtractSym - ( ExtractSym, - ExtractSym1, - ) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1) -import Grisette.Internal.Core.Data.Class.PPrint (PPrint, PPrint1) -import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) -import Grisette.Internal.Core.Data.Class.SymEq (SymEq, SymEq1) -import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd, SymOrd1) -import Grisette.Internal.Core.Data.Class.ToCon (ToCon, ToCon1) -import Grisette.Internal.Core.Data.Class.ToSym (ToSym, ToSym1) -import Grisette.Internal.SymPrim.AllSyms (AllSyms, AllSyms1) -import Grisette.Internal.TH.DeriveBuiltin - ( deriveBuiltinExtra, - ) -import Grisette.Internal.TH.DeriveInstanceProvider - ( Strategy (Anyclass, Stock, ViaDefault, WithNewtype), - ) -import Grisette.Internal.TH.DeriveTypeParamHandler - ( DeriveTypeParamHandler (handleBody, handleTypeParams), - SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler), - ) -import Grisette.Internal.TH.DeriveUnifiedInterface - ( deriveFunctorArgUnifiedInterfaceExtra, - ) -import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) -import Grisette.Internal.TH.Util (classParamKinds) -import Grisette.Unified.Internal.Class.UnifiedSymEq - ( UnifiedSymEq (withBaseSymEq), - UnifiedSymEq1 (withBaseSymEq1), - ) -import Grisette.Unified.Internal.Class.UnifiedSymOrd - ( UnifiedSymOrd (withBaseSymOrd), - UnifiedSymOrd1 (withBaseSymOrd1), - ) -import Language.Haskell.TH - ( Dec, - Kind, - Name, - Pred, - Q, - Type - ( AppT, - ArrowT, - ConT, - EqualityT, - InfixT, - ListT, - LitT, - ParensT, - PromotedConsT, - PromotedNilT, - PromotedT, - PromotedTupleT, - TupleT, - UInfixT, - UnboxedSumT, - UnboxedTupleT, - VarT, - WildCardT - ), - appT, - conT, - pprint, - ) -import Language.Haskell.TH.Datatype - ( DatatypeInfo (datatypeVariant), - DatatypeVariant (Datatype, Newtype), - reifyDatatype, - ) -import Language.Haskell.TH.Syntax (Lift) - -newtypeDefaultStrategy :: Name -> Q Strategy -newtypeDefaultStrategy nm - | nm == ''Show = return $ Stock nm - | nm == ''PPrint = return $ ViaDefault nm - | nm == ''Lift = return $ Stock nm - | nm == ''ToCon = return $ ViaDefault nm - | nm == ''ToSym = return $ ViaDefault nm - | otherwise = return $ WithNewtype nm - -dataDefaultStrategy :: Name -> Q Strategy -dataDefaultStrategy nm - | nm == ''Show = return $ Stock nm - | nm == ''Eq = return $ Stock nm - | nm == ''Ord = return $ Stock nm - | nm == ''Lift = return $ Stock nm - | nm == ''NFData = return $ Anyclass nm - | nm == ''Hashable = return $ Anyclass nm - | nm == ''Serial = return $ Anyclass nm - | nm == ''ToCon = return $ ViaDefault nm - | nm == ''ToSym = return $ ViaDefault nm - | nm == ''AllSyms = return $ ViaDefault nm - | nm == ''EvalSym = return $ ViaDefault nm - | nm == ''ExtractSym = return $ ViaDefault nm - | nm == ''PPrint = return $ ViaDefault nm - | nm == ''Mergeable = return $ ViaDefault nm - | nm == ''SymEq = return $ ViaDefault nm - | nm == ''SymOrd = return $ ViaDefault nm - | nm == ''SubstSym = return $ ViaDefault nm - | otherwise = fail $ "Unsupported class: " <> show nm - -allNeededConstraints :: Name -> [Name] -allNeededConstraints nm - | nm == ''Show = [''Show, ''Show1] - | nm == ''Eq = [''Eq, ''Eq1] - | nm == ''Ord = [''Ord, ''Ord1] - | nm == ''Lift = [''Lift] - | nm == ''NFData = [''NFData, ''NFData1] - | nm == ''Hashable = [''Hashable, ''Hashable1] - | nm == ''Serial = [''Serial] - | nm == ''AllSyms = [''AllSyms, ''AllSyms1] - | nm == ''EvalSym = - [''EvalSym, ''EvalSym1, ''Mergeable, ''Mergeable1] - | nm == ''ExtractSym = [''ExtractSym, ''ExtractSym1] - | nm == ''PPrint = [''PPrint, ''PPrint1] - | nm == ''Mergeable = [''Mergeable1, ''Mergeable1] - | nm == ''ToCon = [''ToCon, ''ToCon1] - | nm == ''ToSym = [''ToSym, ''ToSym1] - | nm == ''SymEq = [''SymEq, ''SymEq1, ''Mergeable, ''Mergeable1] - | nm == ''SymOrd = [''SymOrd, ''SymOrd1, ''Mergeable, ''Mergeable1] - | nm == ''SubstSym = - [''SubstSym, ''SubstSym, ''Mergeable, ''Mergeable1] - | otherwise = [] - -newtype FixInnerConstraints = FixInnerConstraints {cls :: Name} - -needFix :: Type -> Bool -needFix (AppT a b) = needFix a || needFix b -needFix VarT {} = True -needFix ConT {} = False -needFix PromotedT {} = False -needFix (InfixT a _ b) = needFix a || needFix b -needFix (UInfixT a _ b) = needFix a || needFix b -needFix (ParensT a) = needFix a -needFix TupleT {} = False -needFix UnboxedTupleT {} = False -needFix UnboxedSumT {} = False -needFix ArrowT = False -needFix EqualityT = False -needFix ListT = False -needFix PromotedTupleT {} = False -needFix PromotedNilT = False -needFix PromotedConsT = False -needFix LitT {} = False -needFix WildCardT = False -#if MIN_VERSION_template_haskell(2,17,0) -needFix MulArrowT = False -#endif -#if MIN_VERSION_template_haskell(2,19,0) -needFix (PromotedInfixT a _ b) = needFix a || needFix b -needFix (PromotedUInfixT a _ b) = needFix a || needFix b -#endif -needFix t = error $ "Unsupported type in derivation: " <> pprint t - -instance DeriveTypeParamHandler FixInnerConstraints where - handleTypeParams _ _ = return - handleBody FixInnerConstraints {..} types = do - kinds <- classParamKinds cls - concat <$> mapM (handle kinds) (filter (any needFix) $ nub types) - where - handle :: [Kind] -> [Type] -> Q [Pred] - handle k tys - | length k /= length tys = - fail "FixInnerConstraints: kind and type length mismatch" - | otherwise = do - constr <- foldl appT (conT cls) $ return <$> tys - return [constr] - --- | Derive instances for a type with the given name, with the predefined --- strategy. -derivePredefined :: Name -> Name -> Q [Dec] -derivePredefined cls name - | cls == ''Generic = - deriveWithHandlers [] (Stock ''Generic) True 0 [name] -derivePredefined cls name - | cls == ''UnifiedSymEq = - deriveFunctorArgUnifiedInterfaceExtra - [] - -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable False, - -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable1 False - - ''UnifiedSymEq - 'withBaseSymEq - ''UnifiedSymEq1 - 'withBaseSymEq1 - name -derivePredefined cls name - | cls == ''UnifiedSymOrd = - deriveFunctorArgUnifiedInterfaceExtra - [] - -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable False, - -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable1 False - - ''UnifiedSymOrd - 'withBaseSymOrd - ''UnifiedSymOrd1 - 'withBaseSymOrd1 - name -derivePredefined cls name = do - d <- reifyDatatype name - strategy <- - if - | datatypeVariant d == Datatype -> dataDefaultStrategy cls - | datatypeVariant d == Newtype -> newtypeDefaultStrategy cls - | otherwise -> - fail "Currently only non-GADTs data or newtype are supported." - deriveBuiltinExtra - [] - ( Just - [ -- SomeDeriveTypeParamHandler $ ModeTypeParamHandler evmode, - SomeDeriveTypeParamHandler $ FixInnerConstraints cls - ] - ) - False - strategy - (allNeededConstraints cls) - name - --- | Derive instances for a type with the given name, with the predefined --- strategy. --- --- Multiple classes can be derived at once. -derivePredefinedMultipleClasses :: - [Name] -> Name -> Q [Dec] -derivePredefinedMultipleClasses clss name = - concat <$> traverse (`derivePredefined` name) clss - -allGrisetteClasses :: [Name] -allGrisetteClasses = - [ ''Generic, - ''Show, - ''Eq, - ''Ord, - ''Lift, - ''NFData, - ''Hashable, - ''Serial, - ''AllSyms, - ''EvalSym, - ''ExtractSym, - ''PPrint, - ''Mergeable, - ''SymEq, - ''SymOrd, - ''SubstSym, - ''ToCon, - ''ToSym, - ''UnifiedSymEq, - ''UnifiedSymOrd - ] - --- | Derive specified classes for a type with the given name. --- --- Support the same set of classes as 'deriveAll'. -derive :: Name -> [Name] -> Q [Dec] -derive = flip derivePredefinedMultipleClasses - --- | Derive all classes related to Grisette for a type with the given name. --- --- Classes that are be derived by this procedure are: --- --- * 'Generic' --- * 'Show' --- * 'Eq' --- * 'Ord' --- * 'Lift' --- * 'NFData' --- * 'Hashable' --- * 'Serial' --- * 'AllSyms' --- * 'EvalSym' --- * 'ExtractSym' --- * 'PPrint' --- * 'Mergeable' --- * 'SymEq' --- * 'SymOrd' --- * 'SubstSym' --- * 'ToCon' --- * 'ToSym' --- * 'UnifiedSymEq' --- * 'UnifiedSymOrd' --- --- 'Ord' isn't valid for all types (symbolic-only types), so it may be necessary --- to exclude it. --- --- 'deriveAll' needs the following language extensions: --- --- * DeriveAnyClass --- * DeriveGeneric --- * DeriveLift --- * DerivingVia --- * FlexibleContexts --- * FlexibleInstances --- * MonoLocalBinds --- * MultiParamTypeClasses --- * ScopedTypeVariables --- * StandaloneDeriving --- * TemplateHaskell --- * TypeApplications --- * UndecidableInstances --- --- Deriving for a newtype may also need --- --- * GeneralizedNewtypeDeriving --- --- You may get warnings if you don't have the following extensions: --- --- * TypeOperators --- --- It also requires that the v'Generics.Deriving.Default.Default' data --- constructor is visible. --- You may get strange errors if you only import --- v'Generics.Deriving.Default.Default' type but not the data constructor. -deriveAll :: Name -> Q [Dec] -deriveAll = derivePredefinedMultipleClasses allGrisetteClasses - --- | Derive all classes related to Grisette for a type with the given name, --- except for the given classes. --- --- Excluding 'Ord' or 'SymOrd' will also exclude 'UnifiedSymOrd'. --- Excluding 'Eq' or 'SymEq' will also exclude 'UnifiedSymEq'. -deriveAllExcept :: Name -> [Name] -> Q [Dec] -deriveAllExcept nm clss = - derivePredefinedMultipleClasses - (filter (`notElem` allExcluded) allGrisetteClasses) - nm - where - allExcluded = - ([''UnifiedSymEq | ''Eq `elem` clss || ''SymEq `elem` clss]) - <> ([''UnifiedSymOrd | ''Ord `elem` clss || ''SymOrd `elem` clss]) - <> clss diff --git a/src/Grisette/Internal/TH/DeriveTypeParamHandler.hs b/src/Grisette/Internal/TH/DeriveTypeParamHandler.hs deleted file mode 100644 --- a/src/Grisette/Internal/TH/DeriveTypeParamHandler.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Internal.TH.DeriveTypeParamHandler --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.TH.DeriveTypeParamHandler - ( DeriveTypeParamHandler (..), - NatShouldBePositive (..), - IsFPBits (..), - PrimaryConstraint (..), - SomeDeriveTypeParamHandler (..), - ) -where - -import GHC.TypeLits (KnownNat, Nat, type (<=)) -import Grisette.Internal.SymPrim.FP (ValidFP) -import Grisette.Internal.TH.Util - ( allSameKind, - classParamKinds, - concatPreds, - getTypeWithMaybeSubst, - ) -import Language.Haskell.TH (Kind, Name, Pred, Q, Type (ConT), appT, conT) -import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit, tvKind) - --- | A derive type param handler handles type parameters and provides --- constraints or instantiations for them. --- --- The first argument is the number of types that are zipped together. For --- most classes, this is 1, but for some classes, like 'Grisette.ToCon', this is --- 2. --- --- The second argument is the handler itself. --- --- The third argument is a list of type parameters and their constraints. Each --- entry in the list corresponds to a type parameter of the datatype. The --- first element in the pair is a list of zipped type parameters with possibly --- concrete types. For example, if we are deriving 'Grisette.ToCon' for --- `Either`, the argument will be: --- --- > [([(e0, Nothing), (e1, Nothing)], Nothing), --- > ([(a0, Nothing), (a1, Nothing)], Nothing)] --- --- We can see that the type parameters for the concrete and symbolic `Either` --- types are zipped together: the first element of the list are for the error --- types, and the second element of the list are for the value types. --- --- The handler may concretize some types, or add constraints based on the type --- parameters. -class DeriveTypeParamHandler handler where - handleTypeParams :: - Int -> - handler -> - [([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])] -> - Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])] - handleBody :: handler -> [[Type]] -> Q [Pred] - --- | Ensures that type parameters with the kind 'Nat' are known and positive. -data NatShouldBePositive = NatShouldBePositive - -instance DeriveTypeParamHandler NatShouldBePositive where - handleTypeParams _ _ = mapM (uncurry handle) - where - handle :: - [(TyVarBndrUnit, Maybe Type)] -> - Maybe [Pred] -> - Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) - handle [] preds = return ([], preds) - handle tys _ - | not (allSameKind (map fst tys)) = - fail "NatShouldBePositive: All type parameters must be aligned " - handle (ty : tys) Nothing - | tvKind (fst ty) == ConT ''Nat = do - let (t : ts) = map (uncurry getTypeWithMaybeSubst) $ ty : tys - knownPred <- [t|KnownNat $t|] - geq1Pred <- [t|1 <= $t|] - eqPreds <- mapM (\t' -> [t|$t ~ $t'|]) ts - return (ty : tys, Just $ knownPred : geq1Pred : eqPreds) - handle tys preds = return (tys, preds) - handleBody _ _ = return [] - --- | Ensures that the type parameters are valid for floating point operations. -data IsFPBits = IsFPBits {ebIdx :: Int, sbIdx :: Int} - -instance DeriveTypeParamHandler IsFPBits where - handleTypeParams _ (IsFPBits ebIdx sbIdx) tys - | ebIdx >= length tys = - fail "IsFPBits: ebIdx out of bounds" - | sbIdx >= length tys = - fail "IsFPBits: sbIdx out of bounds" - | otherwise = do - let eb = tys !! ebIdx - let ebts = map (uncurry getTypeWithMaybeSubst) (fst eb) - let sb = tys !! sbIdx - let sbts = map (uncurry getTypeWithMaybeSubst) (fst sb) - case (ebts, sbts) of - _ - | length ebts /= length sbts -> - fail $ - "IsFPBits: eb and sb must have the same number of type " - <> "parameters. This might happen because of a bug in " - <> "Grisette" - | not (allSameKind (fst <$> fst eb)) -> - fail "IsFPBits: All type parameters must be aligned" - | not (allSameKind (fst <$> fst sb)) -> - fail "IsFPBits: All type parameters must be aligned" - ([], []) -> return tys - ((et : ets), (st : sts)) -> do - validFloat <- [t|ValidFP $et $st|] - eqebPreds <- mapM (\et' -> [t|$et ~ $et'|]) ets - eqsbPreds <- mapM (\st' -> [t|$st ~ $st'|]) sts - return $ - zipWith - ( \i (ts, preds) -> - if i == ebIdx - then - ( ts, - concatPreds - (Just $ validFloat : eqebPreds ++ eqsbPreds) - preds - ) - else - if i == sbIdx - then (ts, concatPreds (Just []) preds) - else (ts, preds) - ) - [0 ..] - tys - _ -> fail "IsFPBits: This should never happen" - handleBody _ _ = return [] - --- | Adds a primary constraint to the type parameters. It applies the class --- to each type parameter that are zipped into a list, with the desired kinds. --- --- For example, if we are deriving 'Grisette.ToCon' for `Either`, and the input --- to this handler is as follows: --- --- > [([(e0, Nothing), (e1, Nothing)], Nothing), --- > ([(a0, Nothing), (a1, Nothing)], Nothing)] --- --- Then this will generate constraints for the type parameters of `Either`: --- --- > [([(e0, Nothing), (e1, Nothing)], Just [ToCon e0 e1]), --- > ([(a0, Nothing), (a1, Nothing)], Just [ToCon a0 a1])] --- --- Type parameters that are already handled by other handlers can be ignored. -data PrimaryConstraint = PrimaryConstraint - { className :: Name, - ignoreIfAlreadyHandled :: Bool - } - -instance DeriveTypeParamHandler PrimaryConstraint where - handleTypeParams - _ - (PrimaryConstraint className ignoreIfAlreadyHandled) - tys = do - kinds <- classParamKinds className - mapM (uncurry (handle kinds)) tys - where - handle :: - [Kind] -> - [(TyVarBndrUnit, Maybe Type)] -> - Maybe [Pred] -> - Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) - handle _ [] preds = return ([], preds) - handle _ tys _ - | not (allSameKind (map fst tys)) = - fail "PrimaryConstraint: All type parameters must be aligned" - handle _ tys (Just preds) - | ignoreIfAlreadyHandled = - return (tys, Just preds) - handle kinds tys preds - | (tvKind . fst <$> tys) == kinds = do - ts <- mapM (uncurry getTypeWithMaybeSubst) tys - cls <- foldl appT (conT className) $ return <$> ts - return (tys, concatPreds (Just [cls]) preds) - handle _ tys preds = return (tys, preds) - handleBody (PrimaryConstraint _ _) _ = return [] - --- | A type that can handle type parameters. -data SomeDeriveTypeParamHandler where - SomeDeriveTypeParamHandler :: - (DeriveTypeParamHandler handler) => - handler -> - SomeDeriveTypeParamHandler - -instance DeriveTypeParamHandler SomeDeriveTypeParamHandler where - handleTypeParams n (SomeDeriveTypeParamHandler h) = handleTypeParams n h - handleBody (SomeDeriveTypeParamHandler h) = handleBody h diff --git a/src/Grisette/Internal/TH/DeriveUnifiedInterface.hs b/src/Grisette/Internal/TH/DeriveUnifiedInterface.hs deleted file mode 100644 --- a/src/Grisette/Internal/TH/DeriveUnifiedInterface.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Internal.TH.DeriveUnifiedInterface --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.TH.DeriveUnifiedInterface - ( TypeableMode (..), - PrimaryUnifiedConstraint (..), - UnifiedInstance (..), - deriveUnifiedInterfaceExtra, - deriveUnifiedInterface, - deriveUnifiedInterfaces, - deriveUnifiedInterface1Extra, - deriveUnifiedInterface1, - deriveUnifiedInterface1s, - deriveFunctorArgUnifiedInterfaceExtra, - deriveFunctorArgUnifiedInterface, - deriveFunctorArgUnifiedInterfaces, - ) -where - -import Control.Monad (unless) -import Data.Typeable (Typeable) -import Grisette.Internal.TH.DeriveInstanceProvider - ( DeriveInstanceProvider (instanceDeclaration), - ) -import Grisette.Internal.TH.DeriveTypeParamHandler - ( DeriveTypeParamHandler (handleBody, handleTypeParams), - NatShouldBePositive (NatShouldBePositive), - SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler), - ) -import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) -import Grisette.Internal.TH.Util - ( allSameKind, - classParamKinds, - concatPreds, - getTypeWithMaybeSubst, - tvIsMode, - tvIsStar, - tvIsStarToStar, - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag) -import Grisette.Unified.Internal.Util (withMode) -import Language.Haskell.TH - ( Dec, - Exp, - Inline (Inline), - Kind, - Name, - Phases (AllPhases), - Pred, - Q, - RuleMatch (FunLike), - Type (ConT), - appT, - conT, - instanceD, - lam1E, - newName, - normalB, - pragInlD, - valD, - varE, - varP, - ) -import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit, kindedTV, tvKind) - --- | Add a 'Typeable' constraint to the modes. -data TypeableMode = TypeableMode - -instance DeriveTypeParamHandler TypeableMode where - handleTypeParams n _ tys = do - unless (n == 1) $ - fail $ - "TypeableMode: unified type class should have exactly one type " - <> "parameter" - let numModeParam = length $ (filter (tvIsMode . fst . head)) $ fst <$> tys - newTys <- - if numModeParam == 0 - then do - nm <- newName "mode" - return $ - ( [(kindedTV nm (ConT ''EvalModeTag), Nothing)], - Nothing - ) - : tys - else - if numModeParam == 1 - then return tys - else fail "TypeableMode: multiple mode type variables found" - mapM (uncurry handleMode) newTys - where - handleMode :: - [(TyVarBndrUnit, Maybe Type)] -> - Maybe [Pred] -> - Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) - handleMode [(tv, substTy)] preds | tvIsMode tv = do - typeable <- [t|Typeable $(getTypeWithMaybeSubst tv substTy)|] - return ([(tv, substTy)], concatPreds (Just [typeable]) preds) - handleMode tys preds = return (tys, preds) - handleBody _ _ = return [] - --- | Add a primary unified constraint that applies to all the type parameters --- with the desired kind. -data PrimaryUnifiedConstraint = PrimaryUnifiedConstraint Name Bool - -instance DeriveTypeParamHandler PrimaryUnifiedConstraint where - handleTypeParams - n - (PrimaryUnifiedConstraint className ignoreIfAlreadyHandled) - tys = do - unless (n == 1) $ - fail $ - "TypeableMode: unified type class should have exactly one type " - <> "parameter" - kinds <- classParamKinds className - let modes = filter (tvIsMode . fst . head) $ fst <$> tys - case modes of - [] -> fail "PrimaryUnifiedConstraint: No mode type variable found" - [[md]] -> do - mdTy <- uncurry getTypeWithMaybeSubst md - mapM (uncurry $ handle kinds mdTy) tys - [_] -> - fail "PrimaryUnifiedConstraint: multiple mode type variables found" - _ -> - fail "PrimaryUnifiedConstraint: multiple mode type variables found" - where - handle :: - [Kind] -> - Type -> - [(TyVarBndrUnit, Maybe Type)] -> - Maybe [Pred] -> - Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) - handle _ _ [] preds = return ([], preds) - handle _ _ tys (Just preds) - | ignoreIfAlreadyHandled = - return (tys, Just preds) - handle _ _ tys _ - | not (allSameKind (map fst tys)) = - fail - "PrimaryUnifiedConstraint: All type parameters must be aligned" - handle kinds modety tys preds - | ConT ''EvalModeTag : (tvKind . fst <$> tys) == kinds = do - ts <- mapM (uncurry getTypeWithMaybeSubst) tys - cls <- - foldl appT (appT (conT className) (return modety)) $ - return <$> ts - return (tys, concatPreds (Just [cls]) preds) - handle _ _ tys preds = return (tys, preds) - handleBody (PrimaryUnifiedConstraint _ _) _ = return [] - --- | Provide an instance for a unified interface. -data UnifiedInstance = UnifiedInstance - { _cls :: Name, - _clsWithFunc :: Name, - _withFunc :: Name, - _withFunc1 :: Maybe Name - } - -instance DeriveInstanceProvider UnifiedInstance where - instanceDeclaration - (UnifiedInstance cls clsWithFunc withFunc maybeWithFunc1) - tys' - ctx - ty' = do - unless (all ((== 1) . length) tys') $ - fail "UnifiedInstance: only support classes with one type parameter" - unless (length ty' == 1) $ - fail "UnifiedInstance: only support classes with one type parameter" - let tys = head <$> tys' - let modes = - map (uncurry getTypeWithMaybeSubst) $ filter (tvIsMode . fst) tys - let stars = - map (uncurry getTypeWithMaybeSubst) $ filter (tvIsStar . fst) tys - let starToStars = - map (uncurry getTypeWithMaybeSubst) $ - filter (tvIsStarToStar . fst) tys - case modes of - [] -> fail "UnifiedInstance: no mode type variables found" - [md] -> do - sequence - [ instanceD - (return ctx) - [t|$(conT cls) $md $(return $ head ty')|] - [ body md clsWithFunc withFunc stars maybeWithFunc1 starToStars, - pragInlD clsWithFunc Inline FunLike AllPhases - ] - ] - _ -> fail "UnifiedInstance: multiple mode type variables found" - where - applyWithFunc :: Name -> Q Type -> Q Type -> Q Exp -> Q Exp - applyWithFunc withFunc mode var exp = - [|$(varE withFunc) @($mode) @($var) $exp|] - body :: - Q Type -> Name -> Name -> [Q Type] -> Maybe Name -> [Q Type] -> Q Dec - body mode clsWithFunc withFunc starVars maybeWithFunc1 starToStarVars = - do - var <- newName "r" - let arg = varP var - let branch = foldr (applyWithFunc withFunc mode) (varE var) starVars - let withModeFunc = 'withMode - case (maybeWithFunc1, starToStarVars) of - (_, []) -> do - let exp = - lam1E - arg - [|$(varE withModeFunc) @($mode) $branch $branch|] - valD (varP clsWithFunc) (normalB exp) [] - (Just withFunc1, _) -> do - let branchWithFunc1 = - foldr (applyWithFunc withFunc1 mode) branch starToStarVars - let exp = - lam1E - arg - [| - $(varE withModeFunc) - @($mode) - $branchWithFunc1 - $branchWithFunc1 - |] - valD (varP clsWithFunc) (normalB exp) [] - (Nothing, _) -> - fail $ - "UnifiedInstance: withFunc1 is not provided, type have " - <> "functor type parameters" - --- | Derive an instance for a unified interface, with extra handlers. -deriveUnifiedInterfaceExtra :: - [SomeDeriveTypeParamHandler] -> - Name -> - Name -> - Name -> - Q [Dec] -deriveUnifiedInterfaceExtra extraHandlers cls withFunc name = - deriveWithHandlers - ( extraHandlers - <> [ SomeDeriveTypeParamHandler TypeableMode, - SomeDeriveTypeParamHandler NatShouldBePositive, - SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls False - ] - ) - (UnifiedInstance cls withFunc withFunc Nothing) - True - 0 - [name] - --- | Derive an instance for a unified interface. -deriveUnifiedInterface :: Name -> Name -> Name -> Q [Dec] -deriveUnifiedInterface = deriveUnifiedInterfaceExtra [] - --- | Derive instances for a list of types for a unified interface. -deriveUnifiedInterfaces :: Name -> Name -> [Name] -> Q [Dec] -deriveUnifiedInterfaces cls withFunc = - fmap concat . mapM (deriveUnifiedInterface cls withFunc) - --- | Derive an instance for a unified interface for functors, with extra --- handlers. -deriveUnifiedInterface1Extra :: - [SomeDeriveTypeParamHandler] -> - Name -> - Name -> - Name -> - Name -> - Name -> - Q [Dec] -deriveUnifiedInterface1Extra extraHandlers cls withFunc cls1 withFunc1 name = - deriveWithHandlers - ( extraHandlers - <> [ SomeDeriveTypeParamHandler TypeableMode, - SomeDeriveTypeParamHandler NatShouldBePositive, - SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls False, - SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls1 False - ] - ) - (UnifiedInstance cls1 withFunc1 withFunc (Just withFunc1)) - True - 1 - [name] - --- | Derive an instance for a unified interface for functors. -deriveUnifiedInterface1 :: - Name -> Name -> Name -> Name -> Name -> Q [Dec] -deriveUnifiedInterface1 = deriveUnifiedInterface1Extra [] - --- | Derive instances for a list of types for a unified interface for functors. -deriveUnifiedInterface1s :: - Name -> Name -> Name -> Name -> [Name] -> Q [Dec] -deriveUnifiedInterface1s cls withFunc cls1 withFunc1 = - fmap concat . mapM (deriveUnifiedInterface1 cls withFunc cls1 withFunc1) - --- | Derive an instance for a unified interface, with extra handlers. The type --- being derived may have functor type parameters. -deriveFunctorArgUnifiedInterfaceExtra :: - [SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Name -> Name -> Q [Dec] -deriveFunctorArgUnifiedInterfaceExtra - extraHandlers - cls - withFunc - cls1 - withFunc1 - name = - deriveWithHandlers - ( extraHandlers - <> [ SomeDeriveTypeParamHandler TypeableMode, - SomeDeriveTypeParamHandler NatShouldBePositive, - SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls False, - SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls1 False - ] - ) - (UnifiedInstance cls withFunc withFunc (Just withFunc1)) - True - 0 - [name] - --- | Derive an instance for a unified interface. The type being derived may have --- functor type parameters. -deriveFunctorArgUnifiedInterface :: - Name -> Name -> Name -> Name -> Name -> Q [Dec] -deriveFunctorArgUnifiedInterface = deriveFunctorArgUnifiedInterfaceExtra [] - --- | Derive instances for a list of types for a unified interface. The types --- being derived may have functor type parameters. -deriveFunctorArgUnifiedInterfaces :: - Name -> Name -> Name -> Name -> [Name] -> Q [Dec] -deriveFunctorArgUnifiedInterfaces cls withFunc cls1 withFunc1 = - fmap concat - . mapM (deriveFunctorArgUnifiedInterface cls withFunc cls1 withFunc1) diff --git a/src/Grisette/Internal/TH/DeriveWithHandlers.hs b/src/Grisette/Internal/TH/DeriveWithHandlers.hs deleted file mode 100644 --- a/src/Grisette/Internal/TH/DeriveWithHandlers.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- | --- Module : Grisette.Internal.TH.DeriveWithHandlers --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.TH.DeriveWithHandlers - ( deriveWithHandlers, - ) -where - -import Control.Monad (foldM, unless, when) -import Data.List (transpose) -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Grisette.Internal.TH.DeriveInstanceProvider - ( DeriveInstanceProvider (instanceDeclaration), - ) -import Grisette.Internal.TH.DeriveTypeParamHandler - ( DeriveTypeParamHandler (handleBody, handleTypeParams), - SomeDeriveTypeParamHandler, - ) -import Grisette.Internal.TH.Util - ( allSameKind, - dropNTypeParam, - reifyDatatypeWithFreshNames, - substDataType, - ) -import Language.Haskell.TH (Dec, Name, Q) -import Language.Haskell.TH.Datatype - ( ConstructorInfo (constructorFields), - DatatypeInfo (datatypeCons, datatypeVars), - datatypeType, - reifyDatatype, - tvName, - ) - -transposeMatrix :: Int -> [[a]] -> [[a]] -transposeMatrix n [] = replicate n [] -transposeMatrix _ x = transpose x - --- | Derive instances for a list of types with a list of handlers and a --- provider. -deriveWithHandlers :: - (DeriveInstanceProvider provider) => - [SomeDeriveTypeParamHandler] -> - provider -> - Bool -> - Int -> - [Name] -> - Q [Dec] -deriveWithHandlers - handlers - provider - ignoreBodyConstraints - numDroppedTailTypes - names = do - when (numDroppedTailTypes < 0) $ - fail "deriveWithHandlers: numDroppedTailTypes must be non-negative" - when (numDroppedTailTypes > 0 && not ignoreBodyConstraints) $ - fail $ - "deriveWithHandlers: ignoreBodyConstraints must be True if " - <> "numDroppedTailTypes > 0" - when (null names) $ - fail "deriveWithHandlers: no types provided" - datatypes <- - if length names == 1 - then mapM reifyDatatype names - else mapM reifyDatatypeWithFreshNames names - - let tyVars = - transposeMatrix 0 $ - map - (reverse . drop numDroppedTailTypes . reverse . datatypeVars) - datatypes - unless (all allSameKind tyVars) $ - fail "deriveWithHandlers: all type variables must be aligned" - tyVarsWithConstraints <- - foldM - (flip $ handleTypeParams (length datatypes)) - ( map - (\tyVarList -> ((,Nothing) <$> tyVarList, Nothing)) - tyVars - ) - handlers - - let allTyVarsConstraints = - concatMap (fromMaybe [] . snd) tyVarsWithConstraints - let tvWithSubst = - transposeMatrix (length datatypes) $ - fst <$> tyVarsWithConstraints - - let substMaps = - map - ( M.fromList - . mapMaybe - ( \(tv, t) -> do - substTy <- t - return (tvName tv, substTy) - ) - ) - tvWithSubst - let substedTypes = zipWith substDataType datatypes substMaps - tys <- - mapM (dropNTypeParam numDroppedTailTypes . datatypeType) substedTypes - allConstraints <- - ( if ignoreBodyConstraints - then return allTyVarsConstraints - else do - bodyConstraints <- handleBodyWithHandlers substedTypes handlers - return $ allTyVarsConstraints ++ bodyConstraints - ) - instanceDeclaration - provider - (fst <$> tyVarsWithConstraints) - allConstraints - tys - where - handleBodyWithHandlers datatypes handlers = do - let cons = datatypeCons <$> datatypes - let zippedFields = zipFields cons - concat <$> traverse (`handleBody` zippedFields) handlers - zipFields cons = transpose $ concatMap constructorFields <$> cons diff --git a/src/Grisette/Internal/TH/GADT/BinaryOpCommon.hs b/src/Grisette/Internal/TH/GADT/BinaryOpCommon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/BinaryOpCommon.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.BinaryOpCommon +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.BinaryOpCommon + ( BinaryOpClassConfig (..), + BinaryOpFieldConfig (..), + FieldFunExp, + defaultFieldFunExp, + genBinaryOpClause, + genBinaryOpClass, + ) +where + +import Control.Monad (replicateM, unless, when, zipWithM) +import Control.Monad.Identity (IdentityT) +import qualified Data.List as List +import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Set as S +import Grisette.Internal.TH.GADT.Common + ( CheckArgsResult + ( argVars, + constructors, + keptVars + ), + DeriveConfig, + checkArgs, + ctxForVar, + evalModeSpecializeList, + extraConstraint, + freshenCheckArgsResult, + isVarUsedInFields, + specializeResult, + ) +import Language.Haskell.TH + ( Clause, + Dec (FunD, InstanceD), + Exp (VarE), + Kind, + Name, + Pat (VarP, WildP), + Q, + Type (AppT, ConT, VarT), + clause, + conP, + nameBase, + newName, + normalB, + recP, + sigP, + varE, + varP, + varT, + wildP, + ) +import Language.Haskell.TH.Datatype + ( ConstructorInfo (constructorFields, constructorName, constructorVars), + TypeSubstitution (freeVariables), + resolveTypeSynonyms, + tvName, + ) +import Type.Reflection + ( TypeRep, + eqTypeRep, + someTypeRep, + typeRep, + type (:~~:) (HRefl), + ) + +-- | Type of field function expression generator. +type FieldFunExp = M.Map Name Name -> Type -> Q Exp + +-- | Default field function expression generator. +defaultFieldFunExp :: [Name] -> FieldFunExp +defaultFieldFunExp binaryOpFunNames argToFunPat = go + where + go ty = do + let allArgNames = M.keysSet argToFunPat + let typeHasNoArg ty = + S.fromList (freeVariables [ty]) + `S.intersection` allArgNames + == S.empty + let fun0 = varE $ head binaryOpFunNames + fun1 b = [|$(varE $ binaryOpFunNames !! 1) $(go b)|] + fun2 b c = [|$(varE $ binaryOpFunNames !! 2) $(go b) $(go c)|] + fun3 b c d = + [|$(varE $ binaryOpFunNames !! 3) $(go b) $(go c) $(go d)|] + case ty of + AppT (AppT (AppT (VarT _) b) c) d -> fun3 b c d + AppT (AppT (VarT _) b) c -> fun2 b c + AppT (VarT _) b -> fun1 b + _ | typeHasNoArg ty -> fun0 + AppT a b | typeHasNoArg a -> fun1 b + AppT (AppT a b) c | typeHasNoArg a -> fun2 b c + AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3 b c d + VarT nm -> case M.lookup nm argToFunPat of + Just pname -> varE pname + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + +funPatAndExps :: + FieldFunExp -> + [(Type, Kind)] -> + [Type] -> + Q ([Pat], [Exp]) +funPatAndExps fieldFunExpGen argTypes fields = do + let usedArgs = S.fromList $ freeVariables fields + args <- + traverse + ( \(ty, _) -> + case ty of + VarT nm -> + if S.member nm usedArgs + then do + pname <- newName "p" + return (nm, Just pname) + else return ('undefined, Nothing) + _ -> return ('undefined, Nothing) + ) + argTypes + let argToFunPat = + M.fromList $ mapMaybe (\(ty, mpat) -> fmap (ty,) mpat) args + let funPats = fmap (maybe WildP VarP . snd) args + defaultFieldFunExps <- traverse (fieldFunExpGen argToFunPat) fields + return (funPats, defaultFieldFunExps) + +-- | Configuration for a binary operation field generation on a GADT. +data BinaryOpFieldConfig = BinaryOpFieldConfig + { extraPatNames :: [String], + fieldResFun :: [Exp] -> (Exp, Exp) -> Exp -> Q (Exp, [Bool]), + fieldCombineFun :: Name -> [Exp] -> Q (Exp, [Bool]), + fieldDifferentExistentialFun :: Exp -> Q Exp, + fieldLMatchResult :: Q Exp, + fieldRMatchResult :: Q Exp, + fieldFunExp :: FieldFunExp, + fieldFunNames :: [Name] + } + +-- | Generate a clause for a binary operation on a GADT. +genBinaryOpClause :: + BinaryOpFieldConfig -> + [(Type, Kind)] -> + [(Type, Kind)] -> + Bool -> + ConstructorInfo -> + ConstructorInfo -> + Q [Clause] +genBinaryOpClause + (BinaryOpFieldConfig {..}) + lhsArgNewVars + _rhsArgNewVars + isLast + lhsConstructors + rhsConstructors = + do + lhsFields <- mapM resolveTypeSynonyms $ constructorFields lhsConstructors + rhsFields <- mapM resolveTypeSynonyms $ constructorFields rhsConstructors + (funPats, defaultFieldFunExps) <- + funPatAndExps fieldFunExp lhsArgNewVars lhsFields + unless (null extraPatNames) $ + unless isLast $ + fail "Should not happen" + extraPatNames <- traverse newName extraPatNames + let extraPats = fmap VarP extraPatNames + let extraPatExps = fmap VarE extraPatNames + lhsFieldsPatNames <- replicateM (length lhsFields) $ newName "lhsField" + rhsFieldsPatNames <- replicateM (length rhsFields) $ newName "rhsField" + let lhsFieldPats = + conP + (constructorName lhsConstructors) + ( zipWith + (\nm field -> sigP (varP nm) (return field)) + lhsFieldsPatNames + lhsFields + ) + let rhsFieldPats = + conP + (constructorName rhsConstructors) + ( zipWith + (\nm field -> sigP (varP nm) (return field)) + rhsFieldsPatNames + rhsFields + ) + let singleMatchPat = + if null lhsFields + then conP (constructorName lhsConstructors) [] + else recP (constructorName rhsConstructors) [] + let lhsFieldPatExps = fmap VarE lhsFieldsPatNames + let rhsFieldPatExps = fmap VarE rhsFieldsPatNames + + fieldResExpsAndArgsUsed <- + zipWithM + (fieldResFun extraPatExps) + (zip lhsFieldPatExps rhsFieldPatExps) + defaultFieldFunExps + let fieldResExps = fst <$> fieldResExpsAndArgsUsed + let extraArgsUsedByFields = snd <$> fieldResExpsAndArgsUsed + (resExp, extraArgsUsedByResult) <- + fieldCombineFun + (constructorName lhsConstructors) + fieldResExps + + let eqt l r = + [| + eqTypeRep + (typeRep :: TypeRep $(varT $ tvName l)) + (typeRep :: TypeRep $(varT $ tvName r)) + |] + let eqx trueCont l r = do + cmp <- + [| + compare + (someTypeRep (Proxy :: Proxy $(varT $ tvName l))) + (someTypeRep (Proxy :: Proxy $(varT $ tvName r))) + |] + [| + case $(eqt l r) of + Just HRefl -> $(trueCont) + _ -> + $(fieldDifferentExistentialFun cmp) + |] + let construct [] = return resExp + construct ((l, r) : xs) = [|$(eqx (construct xs) l r)|] + + let extraArgsUsed = + fmap or $ + List.transpose $ + extraArgsUsedByResult : extraArgsUsedByFields + let extraArgsPats = + zipWith + (\pat used -> if used then pat else WildP) + extraPats + extraArgsUsed + bothMatched <- + clause + ((return <$> funPats ++ extraArgsPats) ++ [lhsFieldPats, rhsFieldPats]) + ( normalB + [| + $( construct $ + zip + (constructorVars lhsConstructors) + (constructorVars rhsConstructors) + ) + |] + ) + [] + lhsMatched <- + clause + ((wildP <$ funPats) ++ [singleMatchPat, wildP]) + (normalB [|$(fieldLMatchResult)|]) + [] + rhsMatched <- + clause + ((wildP <$ funPats) ++ [wildP, singleMatchPat]) + (normalB [|$(fieldRMatchResult)|]) + [] + if isLast + then return [bothMatched] + else return [bothMatched, lhsMatched, rhsMatched] + +-- | Configuration for a binary operation type class generation on a GADT. +data BinaryOpClassConfig = BinaryOpClassConfig + { binaryOpFieldConfigs :: [BinaryOpFieldConfig], + binaryOpInstanceNames :: [Name], + binaryOpAllowSumType :: Bool, + binaryOpAllowExistential :: Bool + } + +-- | Generate a function for a binary operation on a GADT. +genBinaryOpFun :: + BinaryOpFieldConfig -> + Int -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [ConstructorInfo] -> + [ConstructorInfo] -> + Q Dec +genBinaryOpFun + config + n + lhsArgNewVars + rhsArgNewVars + lhsConstructors + rhsConstructors = do + clauses <- + zipWithM + (genBinaryOpClause config lhsArgNewVars rhsArgNewVars False) + (init lhsConstructors) + (init rhsConstructors) + lastClause <- + genBinaryOpClause + config + lhsArgNewVars + rhsArgNewVars + True + (last lhsConstructors) + (last rhsConstructors) + let instanceFunName = (fieldFunNames config) !! n + return $ FunD instanceFunName (concat clauses ++ lastClause) + +-- | Generate a type class instance for a binary operation on a GADT. +genBinaryOpClass :: + DeriveConfig -> BinaryOpClassConfig -> Int -> Name -> Q [Dec] +genBinaryOpClass deriveConfig (BinaryOpClassConfig {..}) n typName = do + lhsResult <- + specializeResult (evalModeSpecializeList deriveConfig) + =<< freshenCheckArgsResult True + =<< checkArgs + (nameBase $ head binaryOpInstanceNames) + (length binaryOpInstanceNames - 1) + typName + (n == 0 && binaryOpAllowExistential) + n + when (not binaryOpAllowSumType && length (constructors lhsResult) > 1) $ + fail $ + "Cannot derive " + <> nameBase (binaryOpInstanceNames !! n) + <> " for sum type" + rhsResult <- + specializeResult (evalModeSpecializeList deriveConfig) + =<< checkArgs + (nameBase $ head binaryOpInstanceNames) + (length binaryOpInstanceNames - 1) + typName + (n == 0) + n + let keptVars' = keptVars lhsResult + when (typName == ''IdentityT) $ + fail $ + show keptVars' + let isTypeUsedInFields' (VarT nm) = isVarUsedInFields lhsResult nm + isTypeUsedInFields' _ = False + ctxs <- + traverse (uncurry $ ctxForVar (fmap ConT binaryOpInstanceNames)) $ + filter (isTypeUsedInFields' . fst) keptVars' + let keptType = foldl AppT (ConT typName) $ fmap fst keptVars' + instanceFuns <- + traverse + ( \config -> + genBinaryOpFun + config + n + (argVars lhsResult) + (argVars rhsResult) + (constructors lhsResult) + (constructors rhsResult) + ) + binaryOpFieldConfigs + let instanceName = binaryOpInstanceNames !! n + let instanceType = AppT (ConT instanceName) keptType + extraPreds <- + extraConstraint + deriveConfig + typName + instanceName + [] + keptVars' + (constructors lhsResult) + return + [ InstanceD + Nothing + (extraPreds ++ catMaybes ctxs) + instanceType + instanceFuns + ] diff --git a/src/Grisette/Internal/TH/GADT/Common.hs b/src/Grisette/Internal/TH/GADT/Common.hs --- a/src/Grisette/Internal/TH/GADT/Common.hs +++ b/src/Grisette/Internal/TH/GADT/Common.hs @@ -1,4 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Grisette.Internal.TH.GADT.Common @@ -11,89 +17,436 @@ module Grisette.Internal.TH.GADT.Common ( CheckArgsResult (..), checkArgs, + ctxForVar, + EvalModeConfig (..), + DeriveConfig (..), + extraEvalModeConstraint, + extraBitSizeConstraint, + extraFpBitSizeConstraint, + extraExtraMergeableConstraint, + extraConstraint, + specializeResult, + evalModeSpecializeList, + isVarUsedInFields, + freshenCheckArgsResult, ) where -import Control.Monad (when) +import Control.Monad (foldM, unless, when) +import Data.Bifunctor (first) import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Set as S -import Grisette.Internal.TH.Util (occName) +import GHC.TypeLits (KnownNat, Nat, type (<=)) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable + ( Mergeable, + Mergeable1, + Mergeable2, + ) +import Grisette.Internal.SymPrim.FP (ValidFP) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.Util (DecideEvalMode) import Language.Haskell.TH - ( Name, + ( Kind, + Name, + Pred, Q, - Type (VarT), + Type (AppT, ArrowT, ConT, PromotedT, StarT, VarT), + conT, + nameBase, newName, ) import Language.Haskell.TH.Datatype - ( ConstructorInfo (constructorFields), + ( ConstructorInfo (constructorFields, constructorName, constructorVars), DatatypeInfo (datatypeCons, datatypeVars), TypeSubstitution (applySubstitution, freeVariables), reifyDatatype, tvName, ) -import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, mapTVName) +import Language.Haskell.TH.Datatype.TyVarBndr (mapTVName, tvKind) -- | Result of 'checkArgs' for a GADT. data CheckArgsResult = CheckArgsResult { constructors :: [ConstructorInfo], - keptNewNames :: [Name], - keptNewVars :: [TyVarBndr_ ()], - argNewNames :: [Name], - argNewVars :: [TyVarBndr_ ()], - isVarUsedInFields :: Name -> Bool + keptVars :: [(Type, Kind)], + argVars :: [(Type, Kind)] } +-- | Specialize the evaluation mode tags for the t'CheckArgsResult'. +specializeResult :: [(Int, EvalModeTag)] -> CheckArgsResult -> Q CheckArgsResult +specializeResult evalModeConfigs result = do + let modeToName C = 'C + modeToName S = 'S + map <- + foldM + ( \lst (n, tag) -> do + let (_, knd) = lst !! n + return $ + take n lst + ++ [(PromotedT $ modeToName tag, knd)] + ++ drop (n + 1) lst + ) + (keptVars result) + evalModeConfigs + return $ result {keptVars = map} + +freshenConstructorInfo :: ConstructorInfo -> Q ConstructorInfo +freshenConstructorInfo conInfo = do + let vars = constructorVars conInfo + newNames <- traverse (newName . nameBase . tvName) vars + let newVars = zipWith (mapTVName . const) newNames vars + let substMap = M.fromList $ zip (tvName <$> vars) $ VarT <$> newNames + return $ applySubstitution substMap conInfo {constructorVars = newVars} + +-- | Freshen the type variables in the t'CheckArgsResult'. +freshenCheckArgsResult :: Bool -> CheckArgsResult -> Q CheckArgsResult +freshenCheckArgsResult freshenNats result = do + let genNewName :: (Type, Kind) -> Q (Maybe Name) + genNewName (VarT _, knd) = + if not freshenNats && knd == ConT ''Nat + then return Nothing + else Just <$> newName "a" + genNewName _ = return Nothing + keptNewNames <- traverse genNewName (keptVars result) + argNewNames <- traverse genNewName (argVars result) + + let substMap = + M.fromList + $ mapMaybe + ( \(newName, oldVar) -> + case (newName, oldVar) of + (Just newName, (VarT oldName, _)) -> + Just (oldName, VarT newName) + _ -> Nothing + ) + $ zip + (keptNewNames ++ argNewNames) + (keptVars result ++ argVars result) + constructors <- + mapM freshenConstructorInfo $ + applySubstitution substMap $ + constructors result + let newKeptVars = first (applySubstitution substMap) <$> (keptVars result) + let newArgVars = first (applySubstitution substMap) <$> (argVars result) + return $ + result + { constructors = constructors, + keptVars = newKeptVars, + argVars = newArgVars + } + -- | Check if the number of type parameters is valid for a GADT, and return -- new names for the type variables, split into kept and arg parts. checkArgs :: String -> Int -> Name -> + Bool -> Int -> Q CheckArgsResult -checkArgs clsName maxArgNum typName n = do +checkArgs clsName maxArgNum typName allowExistential n = do when (n < 0) $ fail $ unlines [ "Cannot derive " ++ clsName ++ " instance with negative type parameters", - "Requested: " ++ show n, - "Hint: Use a non-negative number of type parameters" + "\tRequested: " ++ show n, + "\tHint: Use a non-negative number of type parameters" ] when (n > maxArgNum) $ fail $ - "Requesting " - <> clsName - <> " instance with more than " - <> show maxArgNum - <> " type parameters" + unlines + [ "Cannot derive " + <> clsName + <> " instance with more than " + <> show maxArgNum + <> " type parameters", + "\tRequested: " <> show n + ] d <- reifyDatatype typName let dvars = datatypeVars d when (length dvars < n) $ fail $ - "Requesting Mergeable" - <> show n - <> " instance, while the type " - <> show typName - <> " has only " - <> show (length dvars) - <> " type variables." - let keptVars = take (length dvars - n) dvars - keptNewNames <- traverse (newName . occName . tvName) keptVars - let keptNewVars = - zipWith (mapTVName . const) keptNewNames keptVars - let argVars = drop (length dvars - n) dvars - argNewNames <- traverse (newName . occName . tvName) argVars - let argNewVars = - zipWith (mapTVName . const) argNewNames argVars - let substMap = - M.fromList $ - zip - (tvName <$> dvars) - (VarT <$> keptNewNames ++ argNewNames) - let constructors = applySubstitution substMap $ datatypeCons d - let allFields = concatMap constructorFields constructors - let allFieldsFreeVars = S.fromList $ freeVariables allFields - let isVarUsedInFields var = S.member var allFieldsFreeVars + unlines + [ "Cannot derive " + <> clsName + <> show n + <> " instance for the type " + <> show typName, + "\tReason: The type " + <> show typName + <> " has only " + <> show (length dvars) + <> " type variables." + ] + let keptVars = + (\bndr -> (VarT $ tvName bndr, tvKind bndr)) + <$> take (length dvars - n) dvars + let argVars = + (\bndr -> (VarT $ tvName bndr, tvKind bndr)) + <$> drop (length dvars - n) dvars + let constructors = datatypeCons d + unless allowExistential $ + mapM_ + ( \c -> + when (constructorVars c /= []) $ + fail $ + unlines + [ "Cannot derive " + <> clsName + <> show n + <> " instance for the type " + <> show typName, + "\tReason: The constructor " + <> nameBase (constructorName c) + <> " has existential variables" + ] + ) + constructors + mapM_ + ( \c -> do + let fields = constructorFields c + let existentialVars = tvName <$> constructorVars c + let fieldReferencedVars = freeVariables fields + let notReferencedVars = + S.fromList existentialVars S.\\ S.fromList fieldReferencedVars + unless (null notReferencedVars) $ + fail $ + unlines + [ "Cannot derive " + <> clsName + <> show n + <> " instance for the type " + <> show typName, + "Reason: Ambiguous existential variable in the constructor: " + <> nameBase (constructorName c) + <> ", this is not supported. Please consider binding the " + <> "existential variable to a field. You can use Proxy type to " + <> "do this." + ] + ) + constructors return $ CheckArgsResult {..} + +isVarUsedInConstructorFields :: [ConstructorInfo] -> Name -> Bool +isVarUsedInConstructorFields constructors var = + let allFields = concatMap constructorFields constructors + allFieldsFreeVars = S.fromList $ freeVariables allFields + in S.member var allFieldsFreeVars + +-- | Check if a variable is used in the fields of a constructor. +isVarUsedInFields :: CheckArgsResult -> Name -> Bool +isVarUsedInFields CheckArgsResult {..} = + isVarUsedInConstructorFields constructors + +-- | Generate a context for a variable in a GADT. +ctxForVar :: [Type] -> Type -> Kind -> Q (Maybe Pred) +ctxForVar instanceExps ty knd = case knd of + StarT -> + Just + <$> [t|$(return $ head instanceExps) $(return ty)|] + AppT (AppT ArrowT StarT) StarT -> + Just + <$> [t|$(return $ instanceExps !! 1) $(return ty)|] + AppT (AppT (AppT ArrowT StarT) StarT) StarT -> + Just + <$> [t|$(return $ instanceExps !! 2) $(return ty)|] + AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) StarT -> + Just + <$> [t|$(return $ instanceExps !! 3) $(return ty)|] + AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) _ -> + fail $ "Unsupported kind: " <> show knd + _ -> return Nothing + +-- | Configuration for constraints for evaluation modes tag. +-- +-- * 'EvalModeConstraints' specifies a list of constraints for the tag, for +-- example, we may use 'Grisette.Unified.EvalModeBase' and +-- 'Grisette.Unified.EvalModeBV' to specify that the evaluation mode must +-- support both base (boolean and data types) and bit vectors. This should be +-- used when the data type uses bit vectors. +-- +-- * 'EvalModeSpecified' specifies a that an evaluation mode tag should be +-- specialized to a specific tag for all the instances. +data EvalModeConfig + = EvalModeConstraints [Name] + | EvalModeSpecified EvalModeTag + +-- | Configuration for deriving instances for a GADT. +data DeriveConfig = DeriveConfig + { evalModeConfig :: [(Int, EvalModeConfig)], + bitSizePositions :: [Int], + fpBitSizePositions :: [(Int, Int)], + needExtraMergeableUnderEvalMode :: Bool, + needExtraMergeableWithConcretizedEvalMode :: Bool + } + +-- | Get all the evaluation modes to specialize in the t'DeriveConfig'. +evalModeSpecializeList :: DeriveConfig -> [(Int, EvalModeTag)] +evalModeSpecializeList DeriveConfig {..} = + mapMaybe + ( \(n, cfg) -> + case cfg of + EvalModeConstraints _ -> Nothing + EvalModeSpecified tag -> Just (n, tag) + ) + evalModeConfig + +instance Semigroup DeriveConfig where + (<>) = (<>) + +instance Monoid DeriveConfig where + mempty = DeriveConfig [] [] [] False False + mappend = (<>) + +-- | Generate extra constraints for evaluation modes. +extraEvalModeConstraint :: + Name -> Name -> [(Type, Kind)] -> (Int, EvalModeConfig) -> Q [Pred] +extraEvalModeConstraint + tyName + instanceName + args + (n, EvalModeConstraints names) + | n >= length args = return [] + | otherwise = do + let (arg, argKind) = args !! n + when (argKind /= ConT ''EvalModeTag) $ + fail $ + "Cannot introduce EvalMode constraint for the " + <> show n + <> "th argument of " + <> show tyName + <> " when deriving the " + <> show instanceName + <> " instance because it is not an EvalModeTag." + traverse (\nm -> [t|$(conT nm) $(return arg)|]) names +extraEvalModeConstraint _ _ _ (_, EvalModeSpecified _) = return [] + +-- | Generate extra constraints for bit vectors. +extraBitSizeConstraint :: Name -> Name -> [(Type, Kind)] -> Int -> Q [Pred] +extraBitSizeConstraint tyName instanceName args n + | n >= length args = return [] + | otherwise = do + let (arg, argKind) = args !! n + when (argKind /= ConT ''Nat) $ + fail $ + "Cannot introduce BitSize constraint for the " + <> show n + <> "th argument of " + <> show tyName + <> " when deriving the " + <> show instanceName + <> " instance because it is not a Nat." + predKnown <- [t|KnownNat $(return arg)|] + predPositive <- [t|1 <= $(return arg)|] + return [predKnown, predPositive] + +-- | Generate extra constraints for floating point exponents and significands. +extraFpBitSizeConstraint :: + Name -> Name -> [(Type, Kind)] -> (Int, Int) -> Q [Pred] +extraFpBitSizeConstraint tyName instanceName args (eb, sb) + | eb >= length args || sb >= length args = return [] + | otherwise = do + let (argEb, argEbKind) = args !! eb + let (argSb, argSbKind) = args !! sb + when (argEbKind /= ConT ''Nat || argSbKind /= ConT ''Nat) $ + fail $ + "Cannot introduce ValidFP constraint for the " + <> show eb + <> "th and " + <> show sb + <> "th arguments of " + <> show tyName + <> " when deriving the " + <> show instanceName + <> " instance because they are not Nats." + pred <- [t|ValidFP $(return argEb) $(return argSb)|] + return [pred] + +-- | Generate extra constraints for 'Mergeable' instances. +extraExtraMergeableConstraint :: [ConstructorInfo] -> [(Type, Kind)] -> Q [Pred] +extraExtraMergeableConstraint constructors args = do + let isTypeUsedInFields' (VarT nm) = + isVarUsedInConstructorFields constructors nm + isTypeUsedInFields' _ = False + catMaybes + <$> traverse + ( \(arg, knd) -> + if isTypeUsedInFields' arg + then + ctxForVar + [ ConT ''Mergeable, + ConT ''Mergeable1, + ConT ''Mergeable2 + ] + arg + knd + else return Nothing + ) + args + +-- | Generate extra constraints for a GADT. +extraConstraint :: + DeriveConfig -> + Name -> + Name -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [ConstructorInfo] -> + Q [Pred] +extraConstraint + DeriveConfig {..} + tyName + instanceName + extraArgs + keptArgs + constructors = do + -- checkAllValidExtraConstraintPosition + -- deriveConfig + -- tyName + -- instanceName + -- keptArgs + evalModePreds <- + traverse + (extraEvalModeConstraint tyName instanceName keptArgs) + evalModeConfig + extraArgEvalModePreds <- + if null evalModeConfig + then + traverse + ( \(arg, kind) -> + if kind == ConT ''EvalModeTag + then (: []) <$> [t|DecideEvalMode $(return arg)|] + else return [] + ) + extraArgs + else return [] + bitSizePreds <- + traverse + (extraBitSizeConstraint tyName instanceName keptArgs) + bitSizePositions + fpBitSizePreds <- + traverse + (extraFpBitSizeConstraint tyName instanceName keptArgs) + fpBitSizePositions + extraMergeablePreds <- + if needExtraMergeableUnderEvalMode + && ( any + ( \case + (_, EvalModeConstraints _) -> True + (_, EvalModeSpecified _) -> False + ) + evalModeConfig + || needExtraMergeableWithConcretizedEvalMode + ) + then extraExtraMergeableConstraint constructors keptArgs + else return [] + return $ + extraMergeablePreds + ++ concat + ( extraArgEvalModePreds + ++ evalModePreds + ++ bitSizePreds + ++ fpBitSizePreds + ) diff --git a/src/Grisette/Internal/TH/GADT/ConvertOpCommon.hs b/src/Grisette/Internal/TH/GADT/ConvertOpCommon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/ConvertOpCommon.hs @@ -0,0 +1,469 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.ConvertOpCommon +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.ConvertOpCommon + ( genConvertOpClass, + ConvertOpClassConfig (..), + defaultFieldFunExp, + ) +where + +import Control.Monad (foldM, replicateM, zipWithM) +import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Set as S +import Grisette.Internal.Core.Data.Class.PlainUnion (unionToCon) +import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge (toUnionSym) +import Grisette.Internal.TH.GADT.Common + ( CheckArgsResult (argVars, constructors, keptVars), + DeriveConfig + ( DeriveConfig, + bitSizePositions, + evalModeConfig, + fpBitSizePositions, + needExtraMergeableUnderEvalMode, + needExtraMergeableWithConcretizedEvalMode + ), + EvalModeConfig (EvalModeConstraints, EvalModeSpecified), + checkArgs, + extraBitSizeConstraint, + extraEvalModeConstraint, + extraExtraMergeableConstraint, + extraFpBitSizeConstraint, + freshenCheckArgsResult, + isVarUsedInFields, + ) +import Grisette.Internal.TH.Util (allUsedNames) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.Util + ( EvalModeConvertible (withModeConvertible'), + ) +import Language.Haskell.TH + ( Body (NormalB), + Clause (Clause), + Dec (FunD, InstanceD), + Exp (VarE), + Kind, + Name, + Overlap (Incoherent), + Pat (VarP, WildP), + Pred, + Q, + Type (AppT, ArrowT, ConT, StarT, VarT), + clause, + conP, + funD, + nameBase, + newName, + normalB, + varE, + varP, + ) +import Language.Haskell.TH.Datatype + ( ConstructorInfo (constructorFields, constructorName), + TypeSubstitution (freeVariables), + resolveTypeSynonyms, + ) + +type FieldFunExp = M.Map Name Name -> Type -> Q Exp + +-- | Default field transformation function. +defaultFieldFunExp :: [Name] -> FieldFunExp +defaultFieldFunExp binaryOpFunNames argToFunPat = go + where + go ty = do + let allArgNames = M.keysSet argToFunPat + let typeHasNoArg ty = + S.fromList (freeVariables [ty]) + `S.intersection` allArgNames + == S.empty + let fun0 = varE $ head binaryOpFunNames + fun1 b = [|$(varE $ binaryOpFunNames !! 1) $(go b)|] + fun2 b c = [|$(varE $ binaryOpFunNames !! 2) $(go b) $(go c)|] + fun3 b c d = + [|$(varE $ binaryOpFunNames !! 3) $(go b) $(go c) $(go d)|] + case ty of + AppT (AppT (AppT (VarT _) b) c) d -> fun3 b c d + AppT (AppT (VarT _) b) c -> fun2 b c + AppT (VarT _) b -> fun1 b + _ | typeHasNoArg ty -> fun0 + AppT a b | typeHasNoArg a -> fun1 b + AppT (AppT a b) c | typeHasNoArg a -> fun2 b c + AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3 b c d + VarT nm -> case M.lookup nm argToFunPat of + Just pname -> varE pname + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + +funPatAndExps :: + FieldFunExp -> + [(Type, Kind)] -> + [Type] -> + Q ([Pat], [Exp]) +funPatAndExps fieldFunExpGen argTypes fields = do + let usedArgs = S.fromList $ freeVariables fields + args <- + traverse + ( \(ty, _) -> + case ty of + VarT nm -> + if S.member nm usedArgs + then do + pname <- newName "p" + return (nm, Just pname) + else return ('undefined, Nothing) + _ -> return ('undefined, Nothing) + ) + argTypes + let argToFunPat = + M.fromList $ mapMaybe (\(ty, mpat) -> fmap (ty,) mpat) args + let funPats = fmap (maybe WildP VarP . snd) args + defaultFieldFunExps <- traverse (fieldFunExpGen argToFunPat) fields + return (funPats, defaultFieldFunExps) + +tagPair :: + DeriveConfig -> + EvalModeTag -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [(Type, Type)] +tagPair deriveConfig convertOpTarget lhsKeptVars rhsKeptVars = + let conKeptVars = + if convertOpTarget == S then lhsKeptVars else rhsKeptVars + symKeptVars = + if convertOpTarget == S then rhsKeptVars else lhsKeptVars + in mapMaybe + ( \case + (n, EvalModeConstraints _) + | n < length conKeptVars && n >= 0 -> + Just (fst $ conKeptVars !! n, fst $ symKeptVars !! n) + _ -> Nothing + ) + (evalModeConfig deriveConfig) + +caseSplitTagPairs :: + DeriveConfig -> + EvalModeTag -> + [(Type, Kind)] -> + [(Type, Kind)] -> + Exp -> + Q Exp +caseSplitTagPairs deriveConfig convertOpTarget lhsKeptVars rhsKeptVars exp = do + let tags = tagPair deriveConfig convertOpTarget lhsKeptVars rhsKeptVars + foldM + ( \exp (lty, rty) -> + [| + withModeConvertible' + @($(return lty)) + @($(return rty)) + $(return exp) + $(return exp) + $(return exp) + |] + ) + exp + tags + +genConvertOpFieldClause :: + DeriveConfig -> + ConvertOpClassConfig -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [(Type, Kind)] -> + ConstructorInfo -> + Q Clause +genConvertOpFieldClause + deriveConfig@DeriveConfig {..} + ConvertOpClassConfig {..} + lhsKeptTypes + rhsKeptTypes + lhsArgTypes + _rhsArgTypes + lhsConInfo = do + fields <- mapM resolveTypeSynonyms $ constructorFields lhsConInfo + (funPats, defaultFieldFunExps) <- funPatAndExps convertFieldFunExp lhsArgTypes fields + fieldsPatNames <- replicateM (length fields) $ newName "field" + fieldPats <- conP (constructorName lhsConInfo) (fmap varP fieldsPatNames) + let fieldPatExps = fmap VarE fieldsPatNames + fieldResExps <- zipWithM convertFieldResFun fieldPatExps defaultFieldFunExps + resExp <- convertFieldCombineFun (constructorName lhsConInfo) fieldResExps + let resUsedNames = allUsedNames resExp + let transformPat (VarP nm) = + if S.member nm resUsedNames then VarP nm else WildP + transformPat p = p + resExpWithTags <- + caseSplitTagPairs + deriveConfig + convertOpTarget + lhsKeptTypes + rhsKeptTypes + resExp + -- let conKeptVars = + -- if convertOpTarget == S then lhsKeptTypes else rhsKeptTypes + -- let symKeptVars = + -- if convertOpTarget == S then rhsKeptTypes else lhsKeptTypes + -- let tags = + -- mapMaybe + -- ( \case + -- (n, EvalModeConstraints _) + -- | n < length conKeptVars && n >= 0 -> + -- Just (fst $ conKeptVars !! n, fst $ symKeptVars !! n) + -- _ -> Nothing + -- ) + -- evalModeConfig + -- resExpWithTags <- + -- foldM + -- ( \exp (lty, rty) -> + -- [| + -- withModeConvertible' + -- @($(return lty)) + -- @($(return rty)) + -- $(return exp) + -- $(return exp) + -- $(return exp) + -- |] + -- ) + -- resExp + -- tags + return $ + Clause + (fmap transformPat $ funPats ++ [fieldPats]) + (NormalB resExpWithTags) + [] + +genConvertOpFun :: + DeriveConfig -> + ConvertOpClassConfig -> + Int -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [ConstructorInfo] -> + Q Dec +genConvertOpFun + deriveConfig + convertOpClassConfig + n + lhsKeptTypes + rhsKeptTypes + lhsArgTypes + rhsArgTypes + lhsConstructors = do + clauses <- + traverse + ( genConvertOpFieldClause + deriveConfig + convertOpClassConfig + lhsKeptTypes + rhsKeptTypes + lhsArgTypes + rhsArgTypes + ) + lhsConstructors + let instanceFunName = (convertOpFunNames convertOpClassConfig) !! n + return $ FunD instanceFunName clauses + +-- | Configuration for a convert operation class. +data ConvertOpClassConfig = ConvertOpClassConfig + { convertOpTarget :: EvalModeTag, + convertOpInstanceNames :: [Name], + convertOpFunNames :: [Name], + convertFieldResFun :: Exp -> Exp -> Q Exp, + convertFieldCombineFun :: Name -> [Exp] -> Q Exp, + convertFieldFunExp :: FieldFunExp + } + +convertCtxForVar :: [Type] -> Type -> Type -> Kind -> Q (Maybe Pred) +convertCtxForVar instanceExps lty rty knd = case knd of + StarT -> + Just + <$> [t|$(return $ head instanceExps) $(return lty) $(return rty)|] + AppT (AppT ArrowT StarT) StarT -> + Just + <$> [t|$(return $ instanceExps !! 1) $(return lty) $(return rty)|] + AppT (AppT (AppT ArrowT StarT) StarT) StarT -> + Just + <$> [t|$(return $ instanceExps !! 2) $(return lty) $(return rty)|] + AppT (AppT (AppT StarT StarT) StarT) _ -> + fail $ "Unsupported kind: " <> show knd + _ -> return Nothing + +-- | Generate extra constraints for a GADT. +extraConstraintConvert :: + DeriveConfig -> + EvalModeTag -> + Name -> + Name -> + [(Type, Kind)] -> + [(Type, Kind)] -> + [ConstructorInfo] -> + Q [Pred] +extraConstraintConvert + DeriveConfig {..} + convertOpTarget + tyName + instanceName + lhsKeptArgs + rhsKeptArgs + rhsConstructors = do + let conKeptVars = if convertOpTarget == S then lhsKeptArgs else rhsKeptArgs + let symKeptVars = if convertOpTarget == S then rhsKeptArgs else lhsKeptArgs + + rhsEvalModePreds <- + if convertOpTarget == S && needExtraMergeableWithConcretizedEvalMode + then + traverse + (extraEvalModeConstraint tyName instanceName rhsKeptArgs) + evalModeConfig + else return [] + extraArgEvalModePreds <- + traverse + ( \case + (n, EvalModeConstraints _) + | n < length lhsKeptArgs && n >= 0 -> + (: []) + <$> [t| + EvalModeConvertible + $(return $ fst $ conKeptVars !! n) + $(return $ fst $ symKeptVars !! n) + |] + _ -> return [] + ) + evalModeConfig + bitSizePreds <- + traverse + (extraBitSizeConstraint tyName instanceName lhsKeptArgs) + bitSizePositions + fpBitSizePreds <- + traverse + (extraFpBitSizeConstraint tyName instanceName lhsKeptArgs) + fpBitSizePositions + extraMergeablePreds <- + if convertOpTarget == S + && ( any + ( \case + (_, EvalModeConstraints _) -> True + (_, EvalModeSpecified _) -> False + ) + evalModeConfig + || needExtraMergeableWithConcretizedEvalMode + ) + then extraExtraMergeableConstraint rhsConstructors rhsKeptArgs + else return [] + return $ + concat + ( rhsEvalModePreds + ++ extraArgEvalModePreds + ++ bitSizePreds + ++ fpBitSizePreds + ++ [extraMergeablePreds] + ) + +-- | Generate a convert operation class instance. +genConvertOpClass :: + DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec] +genConvertOpClass deriveConfig (ConvertOpClassConfig {..}) n typName = do + oldLhsResult <- + freshenCheckArgsResult True + =<< checkArgs + (nameBase $ head convertOpInstanceNames) + (length convertOpInstanceNames - 1) + typName + False + n + oldRhsResult <- freshenCheckArgsResult False oldLhsResult + let lResult = oldLhsResult + let rResult = oldRhsResult + let instanceName = convertOpInstanceNames !! n + let lKeptVars = keptVars lResult + let rKeptVars = keptVars rResult + let lConstructors = constructors lResult + let rConstructors = constructors rResult + let lKeptType = foldl AppT (ConT typName) $ fmap fst lKeptVars + let rKeptType = foldl AppT (ConT typName) $ fmap fst rKeptVars + extraPreds <- + extraConstraintConvert + deriveConfig + convertOpTarget + typName + instanceName + lKeptVars + rKeptVars + rConstructors + unionExtraPreds <- + extraConstraintConvert + deriveConfig {needExtraMergeableWithConcretizedEvalMode = True} + convertOpTarget + typName + instanceName + lKeptVars + rKeptVars + rConstructors + + let instanceType = AppT (AppT (ConT instanceName) lKeptType) rKeptType + let isTypeUsedInFields (VarT nm) = isVarUsedInFields lResult nm + isTypeUsedInFields _ = False + ctxs <- + traverse + ( \((lty, knd), (rty, _)) -> + convertCtxForVar (ConT <$> convertOpInstanceNames) lty rty knd + ) + $ filter (isTypeUsedInFields . fst . fst) + $ zip lKeptVars rKeptVars + + instanceFun <- + genConvertOpFun + deriveConfig + (ConvertOpClassConfig {..}) + n + (keptVars lResult) + (keptVars rResult) + (argVars lResult) + (argVars rResult) + lConstructors + + let instanceUnionType = + case convertOpTarget of + S -> + AppT + (AppT (ConT instanceName) lKeptType) + (AppT (ConT ''Union) rKeptType) + C -> + AppT + (AppT (ConT instanceName) (AppT (ConT ''Union) lKeptType)) + rKeptType + instanceUnionFun <- do + resExp <- + if convertOpTarget == S + then varE 'toUnionSym + else varE 'unionToCon + funD (head convertOpFunNames) [clause [] (normalB $ return resExp) []] + + return $ + InstanceD + (Just Incoherent) + (extraPreds ++ catMaybes ctxs) + instanceType + [instanceFun] + : ( [ InstanceD + (Just Incoherent) + (unionExtraPreds ++ catMaybes ctxs) + instanceUnionType + [instanceUnionFun] + | n == 0 + ] + ) diff --git a/src/Grisette/Internal/TH/GADT/DeriveAllSyms.hs b/src/Grisette/Internal/TH/GADT/DeriveAllSyms.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveAllSyms.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveAllSyms +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveAllSyms + ( deriveGADTAllSyms, + deriveGADTAllSyms1, + deriveGADTAllSyms2, + ) +where + +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms (allSymsS), + AllSyms1 (liftAllSymsS), + AllSyms2 (liftAllSymsS2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + defaultFieldFunExp, + defaultFieldResFun, + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Language.Haskell.TH (Dec, Exp (AppE, ListE, VarE), Name, Q) + +allSymsConfig :: UnaryOpClassConfig +allSymsConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = [], + extraLiftedPatNames = const [], + fieldResFun = defaultFieldResFun, + fieldCombineFun = \_ _ _ _ exp -> + return (AppE (VarE 'mconcat) $ ListE exp, False <$ exp), + fieldFunExp = + defaultFieldFunExp + [ 'allSymsS, + 'liftAllSymsS, + 'liftAllSymsS2 + ] + } + ['allSymsS, 'liftAllSymsS, 'liftAllSymsS2] + ], + unaryOpInstanceNames = [''AllSyms, ''AllSyms1, ''AllSyms2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } + +-- | Derive 'AllSyms' instance for a GADT. +deriveGADTAllSyms :: DeriveConfig -> Name -> Q [Dec] +deriveGADTAllSyms deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 0 + +-- | Derive 'AllSyms1' instance for a GADT. +deriveGADTAllSyms1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTAllSyms1 deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 1 + +-- | Derive 'AllSyms2' instance for a GADT. +deriveGADTAllSyms2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTAllSyms2 deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveEq.hs b/src/Grisette/Internal/TH/GADT/DeriveEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveEq.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveEq + ( deriveGADTEq, + deriveGADTEq1, + deriveGADTEq2, + ) +where + +import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2)) +import Grisette.Internal.TH.GADT.BinaryOpCommon + ( BinaryOpClassConfig + ( BinaryOpClassConfig, + binaryOpAllowSumType, + binaryOpFieldConfigs, + binaryOpInstanceNames + ), + BinaryOpFieldConfig + ( BinaryOpFieldConfig, + extraPatNames, + fieldCombineFun, + fieldDifferentExistentialFun, + fieldFunExp, + fieldFunNames, + fieldLMatchResult, + fieldRMatchResult, + fieldResFun + ), + binaryOpAllowExistential, + defaultFieldFunExp, + genBinaryOpClass, + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Language.Haskell.TH (Dec, Exp (ListE), Q) +import Language.Haskell.TH.Syntax (Name) + +eqConfig :: BinaryOpClassConfig +eqConfig = + BinaryOpClassConfig + { binaryOpFieldConfigs = + [ BinaryOpFieldConfig + { extraPatNames = [], + fieldResFun = \_ (lhs, rhs) f -> + (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], + fieldCombineFun = \_ lst -> + (,[]) <$> [|and $(return $ ListE lst)|], + fieldDifferentExistentialFun = const [|False|], + fieldFunExp = defaultFieldFunExp ['(==), 'liftEq, 'liftEq2], + fieldFunNames = ['(==), 'liftEq, 'liftEq2], + fieldLMatchResult = [|False|], + fieldRMatchResult = [|False|] + } + ], + binaryOpInstanceNames = [''Eq, ''Eq1, ''Eq2], + binaryOpAllowSumType = True, + binaryOpAllowExistential = True + } + +-- | Derive 'Eq' instance for a GADT. +deriveGADTEq :: DeriveConfig -> Name -> Q [Dec] +deriveGADTEq deriveConfig = genBinaryOpClass deriveConfig eqConfig 0 + +-- | Derive 'Eq1' instance for a GADT. +deriveGADTEq1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTEq1 deriveConfig = genBinaryOpClass deriveConfig eqConfig 1 + +-- | Derive 'Eq2' instance for a GADT. +deriveGADTEq2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTEq2 deriveConfig = genBinaryOpClass deriveConfig eqConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveEvalSym.hs b/src/Grisette/Internal/TH/GADT/DeriveEvalSym.hs --- a/src/Grisette/Internal/TH/GADT/DeriveEvalSym.hs +++ b/src/Grisette/Internal/TH/GADT/DeriveEvalSym.hs @@ -22,56 +22,73 @@ ) where -import Grisette.Internal.Core.Data.Class.EvalSym +import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym ( EvalSym (evalSym), EvalSym1 (liftEvalSym), EvalSym2 (liftEvalSym2), ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) import Grisette.Internal.TH.GADT.UnaryOpCommon ( UnaryOpClassConfig ( UnaryOpClassConfig, - unaryOpFieldConfig, - unaryOpFunNames, - unaryOpInstanceNames + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig ), + UnaryOpConfig (UnaryOpConfig), UnaryOpFieldConfig ( UnaryOpFieldConfig, + extraLiftedPatNames, extraPatNames, - fieldCombineFun + fieldCombineFun, + fieldFunExp, + fieldResFun ), + defaultFieldFunExp, + defaultFieldResFun, + defaultUnaryOpInstanceTypeFromConfig, genUnaryOpClass, ) import Language.Haskell.TH ( Dec, - Exp (AppE), + Exp (AppE, ConE), Name, Q, ) -genEvalSym' :: Int -> Name -> Q [Dec] -genEvalSym' n typName = do - genUnaryOpClass - UnaryOpClassConfig - { unaryOpFieldConfig = - UnaryOpFieldConfig - { extraPatNames = ["fillDefault", "model"], - fieldCombineFun = \con exp -> return $ foldl AppE con exp - }, - unaryOpInstanceNames = - [''EvalSym, ''EvalSym1, ''EvalSym2], - unaryOpFunNames = - ['evalSym, 'liftEvalSym, 'liftEvalSym2] - } - n - typName +evalSymConfig :: UnaryOpClassConfig +evalSymConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = ["fillDefault", "model"], + extraLiftedPatNames = const [], + fieldResFun = defaultFieldResFun, + fieldCombineFun = \_ _ con extraPat exp -> do + return (foldl AppE (ConE con) exp, False <$ extraPat), + fieldFunExp = + defaultFieldFunExp ['evalSym, 'liftEvalSym, 'liftEvalSym2] + } + ['evalSym, 'liftEvalSym, 'liftEvalSym2] + ], + unaryOpInstanceNames = + [''EvalSym, ''EvalSym1, ''EvalSym2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } -- | Derive 'EvalSym' instance for a GADT. -deriveGADTEvalSym :: Name -> Q [Dec] -deriveGADTEvalSym = genEvalSym' 0 +deriveGADTEvalSym :: DeriveConfig -> Name -> Q [Dec] +deriveGADTEvalSym deriveConfig = genUnaryOpClass deriveConfig evalSymConfig 0 -- | Derive 'EvalSym1' instance for a GADT. -deriveGADTEvalSym1 = genEvalSym' 1 +deriveGADTEvalSym1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTEvalSym1 deriveConfig = genUnaryOpClass deriveConfig evalSymConfig 1 -- | Derive 'EvalSym2' instance for a GADT. -deriveGADTEvalSym2 :: Name -> Q [Dec] -deriveGADTEvalSym2 = genEvalSym' 2 +deriveGADTEvalSym2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTEvalSym2 deriveConfig = genUnaryOpClass deriveConfig evalSymConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveExtractSym.hs b/src/Grisette/Internal/TH/GADT/DeriveExtractSym.hs --- a/src/Grisette/Internal/TH/GADT/DeriveExtractSym.hs +++ b/src/Grisette/Internal/TH/GADT/DeriveExtractSym.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - {-# HLINT ignore "Unused LANGUAGE pragma" #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- | -- Module : Grisette.Internal.TH.GADT.DeriveExtractSym @@ -18,23 +18,33 @@ ) where -import Grisette.Internal.Core.Data.Class.ExtractSym +import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym ( ExtractSym (extractSymMaybe), ExtractSym1 (liftExtractSymMaybe), ExtractSym2 (liftExtractSymMaybe2), ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) import Grisette.Internal.TH.GADT.UnaryOpCommon ( UnaryOpClassConfig ( UnaryOpClassConfig, - unaryOpFieldConfig, - unaryOpFunNames, - unaryOpInstanceNames + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig ), + UnaryOpConfig (UnaryOpConfig), UnaryOpFieldConfig ( UnaryOpFieldConfig, + extraLiftedPatNames, extraPatNames, - fieldCombineFun + fieldCombineFun, + fieldFunExp, + fieldResFun ), + defaultFieldFunExp, + defaultFieldResFun, + defaultUnaryOpInstanceTypeFromConfig, genUnaryOpClass, ) import Language.Haskell.TH @@ -44,32 +54,46 @@ Q, ) -genExtractSym' :: Int -> Name -> Q [Dec] -genExtractSym' n typName = do - genUnaryOpClass - UnaryOpClassConfig - { unaryOpFieldConfig = - UnaryOpFieldConfig - { extraPatNames = [], - fieldCombineFun = \_ exp -> - return $ AppE (VarE 'mconcat) $ ListE exp - }, - unaryOpInstanceNames = - [''ExtractSym, ''ExtractSym1, ''ExtractSym2], - unaryOpFunNames = - ['extractSymMaybe, 'liftExtractSymMaybe, 'liftExtractSymMaybe2] - } - n - typName +extractSymConfig :: UnaryOpClassConfig +extractSymConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = [], + extraLiftedPatNames = const [], + fieldResFun = defaultFieldResFun, + fieldCombineFun = \_ _ _ _ exp -> + if null exp + then (,[]) <$> [|return mempty|] + else return (AppE (VarE 'mconcat) $ ListE exp, False <$ exp), + fieldFunExp = + defaultFieldFunExp + [ 'extractSymMaybe, + 'liftExtractSymMaybe, + 'liftExtractSymMaybe2 + ] + } + [ 'extractSymMaybe, + 'liftExtractSymMaybe, + 'liftExtractSymMaybe2 + ] + ], + unaryOpInstanceNames = + [''ExtractSym, ''ExtractSym1, ''ExtractSym2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } -- | Derive 'ExtractSym' instance for a GADT. -deriveGADTExtractSym :: Name -> Q [Dec] -deriveGADTExtractSym = genExtractSym' 0 +deriveGADTExtractSym :: DeriveConfig -> Name -> Q [Dec] +deriveGADTExtractSym deriveConfig = genUnaryOpClass deriveConfig extractSymConfig 0 -- | Derive 'ExtractSym1' instance for a GADT. -deriveGADTExtractSym1 :: Name -> Q [Dec] -deriveGADTExtractSym1 = genExtractSym' 1 +deriveGADTExtractSym1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTExtractSym1 deriveConfig = genUnaryOpClass deriveConfig extractSymConfig 1 -- | Derive 'ExtractSym2' instance for a GADT. -deriveGADTExtractSym2 :: Name -> Q [Dec] -deriveGADTExtractSym2 = genExtractSym' 2 +deriveGADTExtractSym2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTExtractSym2 deriveConfig = genUnaryOpClass deriveConfig extractSymConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveGADT.hs b/src/Grisette/Internal/TH/GADT/DeriveGADT.hs --- a/src/Grisette/Internal/TH/GADT/DeriveGADT.hs +++ b/src/Grisette/Internal/TH/GADT/DeriveGADT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# HLINT ignore "Unused LANGUAGE pragma" #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} @@ -13,29 +14,119 @@ -- Portability : GHC only module Grisette.Internal.TH.GADT.DeriveGADT ( deriveGADT, - deriveGADTAll, - deriveGADTAllExcept, + deriveGADTWith, + allClasses0, + allClasses01, + allClasses012, + basicClasses0, + noExistentialClasses0, + ordClasses0, + basicClasses1, + noExistentialClasses1, + ordClasses1, + basicClasses2, + noExistentialClasses2, + ordClasses2, ) where +import Control.Arrow (Arrow (second)) +import Control.DeepSeq (NFData, NFData1, NFData2) +import Data.Bytes.Serial (Serial, Serial1, Serial2) +import Data.Functor.Classes (Eq1, Eq2, Ord1, Ord2, Show1, Show2) +import Data.Hashable (Hashable) +import Data.Hashable.Lifted (Hashable1, Hashable2) import qualified Data.Map as M import qualified Data.Set as S -import Grisette.Internal.Core.Data.Class.EvalSym +import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym ( EvalSym, EvalSym1, EvalSym2, ) -import Grisette.Internal.Core.Data.Class.ExtractSym +import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym ( ExtractSym, ExtractSym1, ExtractSym2, ) -import Grisette.Internal.Core.Data.Class.Mergeable +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable ( Mergeable, Mergeable1, Mergeable2, Mergeable3, ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint + ( PPrint, + PPrint1, + PPrint2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SimpleMergeable, + SimpleMergeable1, + SimpleMergeable2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym + ( SubstSym, + SubstSym1, + SubstSym2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( SymEq, + SymEq1, + SymEq2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + ( SymOrd, + SymOrd1, + SymOrd2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon + ( ToCon, + ToCon1, + ToCon2, + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym + ( ToSym, + ToSym1, + ToSym2, + ) +import Grisette.Internal.Internal.Decl.SymPrim.AllSyms + ( AllSyms, + AllSyms1, + AllSyms2, + ) +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable + ( UnifiedSimpleMergeable, + UnifiedSimpleMergeable1, + UnifiedSimpleMergeable2, + ) +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq + ( UnifiedSymEq, + UnifiedSymEq1, + UnifiedSymEq2, + ) +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd + ( UnifiedSymOrd, + UnifiedSymOrd1, + UnifiedSymOrd2, + ) +import Grisette.Internal.TH.GADT.Common + ( DeriveConfig + ( evalModeConfig, + needExtraMergeableUnderEvalMode, + needExtraMergeableWithConcretizedEvalMode + ), + EvalModeConfig (EvalModeConstraints, EvalModeSpecified), + ) +import Grisette.Internal.TH.GADT.DeriveAllSyms + ( deriveGADTAllSyms, + deriveGADTAllSyms1, + deriveGADTAllSyms2, + ) +import Grisette.Internal.TH.GADT.DeriveEq + ( deriveGADTEq, + deriveGADTEq1, + deriveGADTEq2, + ) import Grisette.Internal.TH.GADT.DeriveEvalSym ( deriveGADTEvalSym, deriveGADTEvalSym1, @@ -46,60 +137,243 @@ deriveGADTExtractSym1, deriveGADTExtractSym2, ) -import Grisette.Internal.TH.GADT.DeriveMergeable (genMergeable, genMergeable', genMergeableAndGetMergingInfoResult) +import Grisette.Internal.TH.GADT.DeriveHashable + ( deriveGADTHashable, + deriveGADTHashable1, + deriveGADTHashable2, + ) +import Grisette.Internal.TH.GADT.DeriveMergeable + ( genMergeable, + genMergeable', + genMergeableAndGetMergingInfoResult, + genMergeableNoExistential, + ) +import Grisette.Internal.TH.GADT.DeriveNFData + ( deriveGADTNFData, + deriveGADTNFData1, + deriveGADTNFData2, + ) +import Grisette.Internal.TH.GADT.DeriveOrd + ( deriveGADTOrd, + deriveGADTOrd1, + deriveGADTOrd2, + ) +import Grisette.Internal.TH.GADT.DerivePPrint + ( deriveGADTPPrint, + deriveGADTPPrint1, + deriveGADTPPrint2, + ) +import Grisette.Internal.TH.GADT.DeriveSerial + ( deriveGADTSerial, + deriveGADTSerial1, + deriveGADTSerial2, + ) +import Grisette.Internal.TH.GADT.DeriveShow + ( deriveGADTShow, + deriveGADTShow1, + deriveGADTShow2, + ) +import Grisette.Internal.TH.GADT.DeriveSimpleMergeable + ( deriveGADTSimpleMergeable, + deriveGADTSimpleMergeable1, + deriveGADTSimpleMergeable2, + ) +import Grisette.Internal.TH.GADT.DeriveSubstSym + ( deriveGADTSubstSym, + deriveGADTSubstSym1, + deriveGADTSubstSym2, + ) +import Grisette.Internal.TH.GADT.DeriveSymEq + ( deriveGADTSymEq, + deriveGADTSymEq1, + deriveGADTSymEq2, + ) +import Grisette.Internal.TH.GADT.DeriveSymOrd + ( deriveGADTSymOrd, + deriveGADTSymOrd1, + deriveGADTSymOrd2, + ) +import Grisette.Internal.TH.GADT.DeriveToCon + ( deriveGADTToCon, + deriveGADTToCon1, + deriveGADTToCon2, + ) +import Grisette.Internal.TH.GADT.DeriveToSym + ( deriveGADTToSym, + deriveGADTToSym1, + deriveGADTToSym2, + ) +import Grisette.Internal.TH.GADT.DeriveUnifiedSimpleMergeable + ( deriveGADTUnifiedSimpleMergeable, + deriveGADTUnifiedSimpleMergeable1, + deriveGADTUnifiedSimpleMergeable2, + ) +import Grisette.Internal.TH.GADT.DeriveUnifiedSymEq + ( deriveGADTUnifiedSymEq, + deriveGADTUnifiedSymEq1, + deriveGADTUnifiedSymEq2, + ) +import Grisette.Internal.TH.GADT.DeriveUnifiedSymOrd + ( deriveGADTUnifiedSymOrd, + deriveGADTUnifiedSymOrd1, + deriveGADTUnifiedSymOrd2, + ) +import Grisette.Internal.TH.Util (dataTypeHasExistential) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) import Language.Haskell.TH (Dec, Name, Q) -deriveProcedureMap :: M.Map Name (Name -> Q [Dec]) +deriveProcedureMap :: M.Map Name (DeriveConfig -> Name -> Q [Dec]) deriveProcedureMap = M.fromList - [ -- (''Mergeable, deriveGADTMergeable), - -- (''Mergeable1, deriveGADTMergeable1), - -- (''Mergeable2, deriveGADTMergeable2), - -- (''Mergeable3, deriveGADTMergeable3), - (''EvalSym, deriveGADTEvalSym), + [ (''EvalSym, deriveGADTEvalSym), (''EvalSym1, deriveGADTEvalSym1), (''EvalSym2, deriveGADTEvalSym2), (''ExtractSym, deriveGADTExtractSym), (''ExtractSym1, deriveGADTExtractSym1), - (''ExtractSym2, deriveGADTExtractSym2) + (''ExtractSym2, deriveGADTExtractSym2), + (''SubstSym, deriveGADTSubstSym), + (''SubstSym1, deriveGADTSubstSym1), + (''SubstSym2, deriveGADTSubstSym2), + (''NFData, deriveGADTNFData), + (''NFData1, deriveGADTNFData1), + (''NFData2, deriveGADTNFData2), + (''Hashable, deriveGADTHashable), + (''Hashable1, deriveGADTHashable1), + (''Hashable2, deriveGADTHashable2), + (''Show, deriveGADTShow), + (''Show1, deriveGADTShow1), + (''Show2, deriveGADTShow2), + (''PPrint, deriveGADTPPrint), + (''PPrint1, deriveGADTPPrint1), + (''PPrint2, deriveGADTPPrint2), + (''AllSyms, deriveGADTAllSyms), + (''AllSyms1, deriveGADTAllSyms1), + (''AllSyms2, deriveGADTAllSyms2), + (''Eq, deriveGADTEq), + (''Eq1, deriveGADTEq1), + (''Eq2, deriveGADTEq2), + (''Ord, deriveGADTOrd), + (''Ord1, deriveGADTOrd1), + (''Ord2, deriveGADTOrd2), + (''SymOrd, deriveGADTSymOrd), + (''SymOrd1, deriveGADTSymOrd1), + (''SymOrd2, deriveGADTSymOrd2), + (''SymEq, deriveGADTSymEq), + (''SymEq1, deriveGADTSymEq1), + (''SymEq2, deriveGADTSymEq2), + (''UnifiedSymEq, deriveGADTUnifiedSymEq), + (''UnifiedSymEq1, deriveGADTUnifiedSymEq1), + (''UnifiedSymEq2, deriveGADTUnifiedSymEq2), + (''UnifiedSymOrd, deriveGADTUnifiedSymOrd), + (''UnifiedSymOrd1, deriveGADTUnifiedSymOrd1), + (''UnifiedSymOrd2, deriveGADTUnifiedSymOrd2), + (''ToSym, deriveGADTToSym), + (''ToSym1, deriveGADTToSym1), + (''ToSym2, deriveGADTToSym2), + (''ToCon, deriveGADTToCon), + (''ToCon1, deriveGADTToCon1), + (''ToCon2, deriveGADTToCon2), + (''Serial, deriveGADTSerial), + (''Serial1, deriveGADTSerial1), + (''Serial2, deriveGADTSerial2), + (''SimpleMergeable, deriveGADTSimpleMergeable), + (''SimpleMergeable1, deriveGADTSimpleMergeable1), + (''SimpleMergeable2, deriveGADTSimpleMergeable2), + (''UnifiedSimpleMergeable, deriveGADTUnifiedSimpleMergeable), + (''UnifiedSimpleMergeable1, deriveGADTUnifiedSimpleMergeable1), + (''UnifiedSimpleMergeable2, deriveGADTUnifiedSimpleMergeable2) ] -deriveSingleGADT :: Name -> Name -> Q [Dec] -deriveSingleGADT typName className = do +deriveSingleGADT :: DeriveConfig -> Name -> Name -> Q [Dec] +deriveSingleGADT deriveConfig typName className = do + let newExtra + | className + `elem` [ ''Eq, + ''Eq1, + ''Eq2, + ''SymEq, + ''SymEq1, + ''SymEq2, + ''SymOrd, + ''SymOrd1, + ''SymOrd2, + ''UnifiedSymEq, + ''UnifiedSymEq1, + ''UnifiedSymEq2, + ''UnifiedSymOrd, + ''UnifiedSymOrd1, + ''UnifiedSymOrd2, + ''UnifiedSimpleMergeable, + ''UnifiedSimpleMergeable1, + ''UnifiedSimpleMergeable2 + ] = + deriveConfig + { needExtraMergeableUnderEvalMode = False, + needExtraMergeableWithConcretizedEvalMode = False + } + | className + `elem` [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2] = + deriveConfig + { evalModeConfig = + second + ( \case + EvalModeConstraints _ -> EvalModeSpecified S + EvalModeSpecified tag -> EvalModeSpecified tag + ) + <$> evalModeConfig deriveConfig, + needExtraMergeableUnderEvalMode = False, + needExtraMergeableWithConcretizedEvalMode = False + } + | className `elem` [''Ord, ''Ord1, ''Ord2] = + deriveConfig + { evalModeConfig = + second + ( \case + EvalModeConstraints _ -> EvalModeSpecified C + EvalModeSpecified tag -> EvalModeSpecified tag + ) + <$> evalModeConfig deriveConfig, + needExtraMergeableUnderEvalMode = False, + needExtraMergeableWithConcretizedEvalMode = False + } + | otherwise = deriveConfig case M.lookup className deriveProcedureMap of - Just procedure -> procedure typName + Just procedure -> procedure newExtra typName Nothing -> fail $ "No derivation available for class " ++ show className --- | Derive the specified classes for a GADT with the given name. --- --- Support the following classes. --- --- * 'Mergeable' --- * 'Mergeable1' --- * 'Mergeable2' --- * 'Mergeable3' --- * 'EvalSym' --- * 'EvalSym1' --- * 'EvalSym2' --- * 'ExtractSym' --- * 'ExtractSym1' --- * 'ExtractSym2' -deriveGADT :: Name -> [Name] -> Q [Dec] -deriveGADT typName classNames = do - let allClassNames = S.toList $ S.fromList classNames - let (ns, ms) = splitMergeable allClassNames - decs <- mapM (deriveSingleGADT typName) ns +deriveGADTWith' :: DeriveConfig -> Name -> [Name] -> Q [Dec] +deriveGADTWith' deriveConfig typName classNameList = do + let classNames = S.fromList classNameList + let (ns, ms) = splitMergeable $ S.toList classNames + decs <- mapM (deriveSingleGADT deriveConfig typName) ns decMergeables <- deriveMergeables ms return $ concat decs ++ decMergeables where + configWithOutExtraMergeable :: DeriveConfig + configWithOutExtraMergeable = + deriveConfig {needExtraMergeableUnderEvalMode = False} deriveMergeables :: [Int] -> Q [Dec] deriveMergeables [] = return [] - deriveMergeables [n] = genMergeable typName n + deriveMergeables [n] = genMergeable configWithOutExtraMergeable typName n deriveMergeables (n : ns) = do - (info, dn) <- genMergeableAndGetMergingInfoResult typName n - dns <- traverse (genMergeable' info typName) ns - return $ dn ++ concatMap snd dns + hasExistential <- dataTypeHasExistential typName + if hasExistential + then do + (info, dn) <- + genMergeableAndGetMergingInfoResult + configWithOutExtraMergeable + typName + n + dns <- + traverse (genMergeable' configWithOutExtraMergeable info typName) ns + return $ dn ++ concatMap snd dns + else do + dns <- + traverse + (genMergeableNoExistential configWithOutExtraMergeable typName) + (n : ns) + return $ concat dns splitMergeable :: [Name] -> ([Name], [Int]) splitMergeable [] = ([], []) splitMergeable (x : xs) = @@ -111,26 +385,351 @@ | x == ''Mergeable3 -> (ns, 3 : is) | otherwise -> (x : ns, is) --- | Derive all (non-functor) classes related to Grisette for a GADT with the --- given name. +-- | Derive the specified classes for a GADT with the given name. -- --- Classes that are derived by this procedure are: +-- Support the following classes. -- -- * 'Mergeable' +-- * 'Mergeable1' +-- * 'Mergeable2' +-- * 'Mergeable3' -- * 'EvalSym' +-- * 'EvalSym1' +-- * 'EvalSym2' -- * 'ExtractSym' +-- * 'ExtractSym1' +-- * 'ExtractSym2' +-- * 'SubstSym' +-- * 'SubstSym1' +-- * 'SubstSym2' +-- * 'NFData' +-- * 'NFData1' +-- * 'NFData2' +-- * 'Hashable' +-- * 'Hashable1' +-- * 'Hashable2' +-- * 'Show' +-- * 'Show1' +-- * 'Show2' +-- * 'PPrint' +-- * 'PPrint1' +-- * 'PPrint2' +-- * 'AllSyms' +-- * 'AllSyms1' +-- * 'AllSyms2' +-- * 'Eq' +-- * 'Eq1' +-- * 'Eq2' +-- * 'Ord' +-- * 'Ord1' +-- * 'Ord2' +-- * 'SymOrd' +-- * 'SymOrd1' +-- * 'SymOrd2' +-- * 'SymEq' +-- * 'SymEq1' +-- * 'SymEq2' +-- * 'UnifiedSymEq' +-- * 'UnifiedSymEq1' +-- * 'UnifiedSymEq2' +-- * 'UnifiedSymOrd' +-- * 'UnifiedSymOrd1' +-- * 'UnifiedSymOrd2' +-- * 'ToSym' +-- * 'ToSym1' +-- * 'ToSym2' +-- * 'ToCon' +-- * 'ToCon1' +-- * 'ToCon2' +-- * 'Serial' +-- * 'Serial1' +-- * 'Serial2' +-- * 'SimpleMergeable' +-- * 'SimpleMergeable1' +-- * 'SimpleMergeable2' -- --- Note that it is okay to derive for non-GADT types using this procedure, and --- it will be slightly more efficient. -deriveGADTAll :: Name -> Q [Dec] -deriveGADTAll typName = - deriveGADT typName [''Mergeable, ''EvalSym, ''ExtractSym] +-- Note that the following type classes cannot be derived for GADTs with +-- existential type variables. +-- +-- * 'Eq1' +-- * 'Eq2' +-- * 'SymEq1' +-- * 'SymEq2' +-- * 'Ord1' +-- * 'Ord2' +-- * 'SymOrd1' +-- * 'SymOrd2' +deriveGADTWith :: DeriveConfig -> [Name] -> [Name] -> Q [Dec] +deriveGADTWith deriveConfig typeNameList classNameList = do + let typeNames = S.toList $ S.fromList typeNameList + concat + <$> traverse + (\typeName -> deriveGADTWith' deriveConfig typeName classNameList) + typeNames --- | Derive all (non-functor) classes related to Grisette for a GADT with the --- given name except the specified classes. -deriveGADTAllExcept :: Name -> [Name] -> Q [Dec] -deriveGADTAllExcept typName classNames = do - deriveGADT typName $ - S.toList $ - S.fromList [''Mergeable, ''EvalSym, ''ExtractSym] - S.\\ S.fromList classNames +-- | Derive the specified classes for a GADT with the given name. +-- +-- See 'deriveGADTWith' for more details. +deriveGADT :: [Name] -> [Name] -> Q [Dec] +deriveGADT = deriveGADTWith mempty + +-- | All the classes that can be derived for GADTs. +-- +-- This includes: +-- +-- * 'Mergeable' +-- * 'EvalSym' +-- * 'ExtractSym' +-- * 'SubstSym' +-- * 'NFData' +-- * 'Hashable' +-- * 'Show' +-- * 'PPrint' +-- * 'AllSyms' +-- * 'Eq' +-- * 'SymEq' +-- * 'SymOrd' +-- * 'UnifiedSymEq' +-- * 'Ord' +-- * 'UnifiedSymOrd' +-- * 'Serial' +-- * 'ToCon' +-- * 'ToSym' +allClasses0 :: [Name] +allClasses0 = basicClasses0 ++ ordClasses0 ++ noExistentialClasses0 + +-- | All the @*1@ classes that can be derived for GADT functors. +-- +-- This includes: +-- +-- * 'Mergeable1' +-- * 'EvalSym1' +-- * 'ExtractSym1' +-- * 'SubstSym1' +-- * 'NFData1' +-- * 'Hashable1' +-- * 'Show1' +-- * 'PPrint1' +-- * 'AllSyms1' +-- * 'Eq1' +-- * 'SymEq1' +-- * 'SymOrd1' +-- * 'UnifiedSymEq1' +-- * 'Ord1' +-- * 'UnifiedSymOrd1' +-- * 'Serial1' +-- * 'ToCon1' +-- * 'ToSym1' +allClasses1 :: [Name] +allClasses1 = basicClasses1 ++ ordClasses1 ++ noExistentialClasses1 + +-- | All the classes that can be derived for GADT functors. +-- +-- This includes all the classes in 'allClasses0' and 'allClasses1'. +allClasses01 :: [Name] +allClasses01 = allClasses0 ++ allClasses1 + +-- | All the @*2@ classes that can be derived for GADT functors. +-- +-- This includes: +-- +-- * 'Mergeable2' +-- * 'EvalSym2' +-- * 'ExtractSym2' +-- * 'SubstSym2' +-- * 'NFData2' +-- * 'Hashable2' +-- * 'Show2' +-- * 'PPrint2' +-- * 'AllSyms2' +-- * 'Eq2' +-- * 'SymEq2' +-- * 'SymOrd2' +-- * 'UnifiedSymEq2' +-- * 'Ord2' +-- * 'UnifiedSymOrd2' +-- * 'Serial2' +-- * 'ToCon2' +-- * 'ToSym2' +allClasses2 :: [Name] +allClasses2 = basicClasses2 ++ ordClasses2 ++ noExistentialClasses2 + +-- | All the classes that can be derived for GADTfunctors. +-- +-- This includes all the classes in 'allClasses0', 'allClasses1', +-- and 'allClasses2'. +allClasses012 :: [Name] +allClasses012 = allClasses0 ++ allClasses1 ++ allClasses2 + +-- | Basic classes for GADTs. +-- +-- This includes: +-- +-- * 'Mergeable' +-- * 'EvalSym' +-- * 'ExtractSym' +-- * 'SubstSym' +-- * 'NFData' +-- * 'Hashable' +-- * 'Show' +-- * 'PPrint' +-- * 'AllSyms' +-- * 'Eq' +-- * 'SymEq' +-- * 'SymOrd' +-- * 'UnifiedSymEq' +-- +-- These classes can be derived for most GADTs. +basicClasses0 :: [Name] +basicClasses0 = + [ ''Mergeable, + ''EvalSym, + ''ExtractSym, + ''SubstSym, + ''NFData, + ''Hashable, + ''Show, + ''PPrint, + ''AllSyms, + ''Eq, + ''SymEq, + ''SymOrd, + ''UnifiedSymEq + ] + +-- | Classes that can only be derived for GADTs without existential type +-- variables. +-- +-- This includes: +-- +-- * 'Serial' +-- * 'ToCon' +-- * 'ToSym' +noExistentialClasses0 :: [Name] +noExistentialClasses0 = [''Serial, ''ToCon, ''ToSym] + +-- | Concrete ordered classes that can be derived for GADTs that +-- +-- * uses unified evaluation mode, or +-- * does not contain any symbolic variables. +-- +-- This includes: +-- +-- * 'Ord' +-- * 'UnifiedSymOrd' +ordClasses0 :: [Name] +ordClasses0 = [''Ord, ''UnifiedSymOrd] + +-- | Basic classes for GADT functors. +-- +-- This includes: +-- +-- * 'Mergeable1' +-- * 'EvalSym1' +-- * 'ExtractSym1' +-- * 'SubstSym1' +-- * 'NFData1' +-- * 'Hashable1' +-- * 'Show1' +-- * 'PPrint1' +-- * 'AllSyms1' +-- * 'Eq1' +-- * 'SymEq1' +-- * 'SymOrd1' +-- * 'UnifiedSymEq1' +basicClasses1 :: [Name] +basicClasses1 = + [ ''Mergeable1, + ''EvalSym1, + ''ExtractSym1, + ''SubstSym1, + ''NFData1, + ''Hashable1, + ''Show1, + ''PPrint1, + ''AllSyms1, + ''Eq1, + ''SymEq1, + ''SymOrd1, + ''UnifiedSymEq1 + ] + +-- | @*1@ classes that can only be derived for GADT functors without existential +-- type variables. +-- +-- This includes: +-- +-- * 'Serial1' +-- * 'ToCon1' +-- * 'ToSym1' +noExistentialClasses1 :: [Name] +noExistentialClasses1 = [''Serial1, ''ToCon1, ''ToSym1] + +-- | @*1@ concrete ordered classes that can be derived for GADT functors that +-- +-- * uses unified evaluation mode, or +-- * does not contain any symbolic variables. +-- +-- This includes: +-- +-- * 'Ord1' +-- * 'UnifiedSymOrd1' +ordClasses1 :: [Name] +ordClasses1 = [''Ord1, ''UnifiedSymOrd1] + +-- | Basic classes for GADT functors. +-- +-- This includes: +-- +-- * 'Mergeable2' +-- * 'EvalSym2' +-- * 'ExtractSym2' +-- * 'SubstSym2' +-- * 'NFData2' +-- * 'Hashable2' +-- * 'Show2' +-- * 'PPrint2' +-- * 'AllSyms2' +-- * 'Eq2' +-- * 'SymEq2' +-- * 'SymOrd2' +-- * 'UnifiedSymEq2' +basicClasses2 :: [Name] +basicClasses2 = + [ ''Mergeable2, + ''EvalSym2, + ''ExtractSym2, + ''SubstSym2, + ''NFData2, + ''Hashable2, + ''Show2, + ''PPrint2, + ''AllSyms2, + ''Eq2, + ''SymEq2, + ''SymOrd2, + ''UnifiedSymEq2 + ] + +-- | @*2@ classes that can only be derived for GADT functors without existential +-- type variables. +-- +-- This includes: +-- +-- * 'Serial2' +-- * 'ToCon2' +-- * 'ToSym2' +noExistentialClasses2 :: [Name] +noExistentialClasses2 = [''Serial2, ''ToCon2, ''ToSym2] + +-- | @*2@ concrete ordered classes that can be derived for GADT functors that +-- +-- * uses unified evaluation mode, or +-- * does not contain any symbolic variables. +-- +-- This includes: +-- +-- * 'Ord2' +-- * 'UnifiedSymOrd2' +ordClasses2 :: [Name] +ordClasses2 = [''Ord2, ''UnifiedSymOrd2] diff --git a/src/Grisette/Internal/TH/GADT/DeriveHashable.hs b/src/Grisette/Internal/TH/GADT/DeriveHashable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveHashable.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveHashable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveHashable + ( deriveGADTHashable, + deriveGADTHashable1, + deriveGADTHashable2, + ) +where + +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable.Lifted + ( Hashable1 (liftHashWithSalt), + Hashable2 (liftHashWithSalt2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + defaultFieldFunExp, + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Language.Haskell.TH (Dec, Name, Q) + +hashableConfig :: UnaryOpClassConfig +hashableConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = ["salt"], + extraLiftedPatNames = const [], + fieldCombineFun = + \_ _ _ [salt] exp -> do + r <- + foldl + (\salt exp -> [|$(return exp) $salt|]) + (return salt) + exp + return (r, [True]), + fieldResFun = \_ _ _ _ fieldPat fieldFun -> do + r <- [|\salt -> $(return fieldFun) salt $(return fieldPat)|] + return (r, [False]), + fieldFunExp = + defaultFieldFunExp + ['hashWithSalt, 'liftHashWithSalt, 'liftHashWithSalt2] + } + ['hashWithSalt, 'liftHashWithSalt, 'liftHashWithSalt2] + ], + unaryOpInstanceNames = + [''Hashable, ''Hashable1, ''Hashable2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } + +-- | Derive 'Hashable' instance for a GADT. +deriveGADTHashable :: DeriveConfig -> Name -> Q [Dec] +deriveGADTHashable deriveConfig = genUnaryOpClass deriveConfig hashableConfig 0 + +-- | Derive 'Hashable1' instance for a GADT. +deriveGADTHashable1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTHashable1 deriveConfig = genUnaryOpClass deriveConfig hashableConfig 1 + +-- | Derive 'Hashable2' instance for a GADT. +deriveGADTHashable2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTHashable2 deriveConfig = genUnaryOpClass deriveConfig hashableConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveMergeable.hs b/src/Grisette/Internal/TH/GADT/DeriveMergeable.hs --- a/src/Grisette/Internal/TH/GADT/DeriveMergeable.hs +++ b/src/Grisette/Internal/TH/GADT/DeriveMergeable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -21,15 +22,16 @@ genMergeableAndGetMergingInfoResult, genMergeable, genMergeable', + genMergeableNoExistential, ) where import Control.Monad (foldM, replicateM, zipWithM) import qualified Data.Map as M import Data.Maybe (catMaybes, isJust, mapMaybe) -import Data.Proxy (Proxy (Proxy)) import qualified Data.Set as S -import Grisette.Internal.Core.Data.Class.Mergeable +import Data.Word (Word16, Word32, Word64, Word8) +import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable ( Mergeable (rootStrategy), Mergeable1 (liftRootStrategy), Mergeable2 (liftRootStrategy2), @@ -41,38 +43,52 @@ import Grisette.Internal.TH.GADT.Common ( CheckArgsResult ( CheckArgsResult, - argNewNames, - argNewVars, + argVars, constructors, - isVarUsedInFields, - keptNewNames, - keptNewVars + keptVars ), + DeriveConfig, checkArgs, + evalModeSpecializeList, + extraConstraint, + isVarUsedInFields, + specializeResult, ) -import Grisette.Internal.TH.Util (occName) +import Grisette.Internal.TH.GADT.UnaryOpCommon (FieldFunExp, UnaryOpClassConfig (UnaryOpClassConfig, unaryOpAllowExistential, unaryOpConfigs, unaryOpExtraVars, unaryOpInstanceNames, unaryOpInstanceTypeFromConfig), UnaryOpConfig (UnaryOpConfig), UnaryOpFunConfig (genUnaryOpFun), defaultUnaryOpInstanceTypeFromConfig, genUnaryOpClass) +import Grisette.Internal.TH.Util (dataTypeHasExistential, integerE, mangleName) import Language.Haskell.TH ( Bang (Bang), Body (NormalB), Clause (Clause), Con (ForallC, GadtC), - Dec (DataD, FunD, InstanceD, SigD), + Dec (DataD, FunD, InstanceD, PragmaD, SigD), Exp (AppE, ConE, VarE), + Inline (Inline), + Kind, Name, Pat (SigP, VarP, WildP), + Phases (AllPhases), + Pragma (InlineP), Pred, Q, + RuleMatch (FunLike), SourceStrictness (NoSourceStrictness), SourceUnpackedness (NoSourceUnpackedness), Type (AppT, ArrowT, ConT, ForallT, StarT, VarT), appE, + caseE, conE, conT, + integerL, lamE, + litP, lookupTypeName, mkName, + nameBase, newName, normalB, + recP, + sigP, tupP, varE, varP, @@ -89,17 +105,16 @@ DatatypeInfo (datatypeCons, datatypeName, datatypeVars), TypeSubstitution (applySubstitution, freeVariables), reifyDatatype, + resolveTypeSynonyms, tvName, ) import Language.Haskell.TH.Datatype.TyVarBndr ( TyVarBndrUnit, - TyVarBndr_, - mapTVFlag, + kindedTVSpecified, plainTVFlag, specifiedSpec, - tvKind, ) -import Language.Haskell.TH.Lib (clause, conP, litE, stringL) +import Language.Haskell.TH.Lib (clause, conP, litE, match, stringL) import Type.Reflection (SomeTypeRep (SomeTypeRep), TypeRep, typeRep) import Unsafe.Coerce (unsafeCoerce) @@ -108,161 +123,120 @@ Name -> Bool -> ConstructorInfo -> - Q (Con, Name, S.Set Int, [Clause], [Clause], [Clause]) + Q (Con, Name, [Clause], [Clause], [Clause]) genMergingInfoCon dataTypeVars tyName isLast con = do - let conName = occName $ constructorName con + let conName = mangleName $ constructorName con let newConName = mkName $ conName <> "MergingInfo" - if null (constructorFields con) && null dataTypeVars - then do - eqClause <- - clause - [conP newConName [], conP newConName []] - (normalB $ conE 'True) - [] - cmpClause0 <- - clause - [conP newConName [], conP newConName []] - (normalB $ conE 'EQ) - [] - cmpClause1 <- - clause - [conP newConName [], wildP] - (normalB $ conE 'LT) - [] - cmpClause2 <- - clause - [wildP, conP newConName []] - (normalB $ conE 'GT) - [] - let cmpClauses = - if isLast - then [cmpClause0] - else [cmpClause0, cmpClause1, cmpClause2] - let nameLit = litE $ stringL conName - let showExp = [|$nameLit <> " " <> show (Proxy @($(conT tyName)))|] - showClause <- - clause - [conP newConName []] - (normalB showExp) - [] - return - ( GadtC [newConName] [] (ConT tyName), - newConName, - S.fromList [], - [eqClause], - cmpClauses, - [showClause] - ) - else do - let oriVars = dataTypeVars ++ constructorVars con - newNames <- traverse (newName . occName . tvName) oriVars - let newVars = fmap VarT newNames - let substMap = M.fromList $ zip (tvName <$> oriVars) newVars - let fields = - zip [0 ..] $ - applySubstitution substMap $ - constructorFields con - let tyFields = - AppT (ConT ''TypeRep) - <$> applySubstitution - substMap - ((VarT . tvName) <$> constructorVars con) - let strategyFields = fmap (AppT (ConT ''MergingStrategy) . snd) fields - tyFieldNamesL <- traverse (const $ newName "p") tyFields - tyFieldNamesR <- traverse (const $ newName "p") tyFields - let tyFieldPatsL = fmap varP tyFieldNamesL - let tyFieldPatsR = fmap varP tyFieldNamesR - let tyFieldVarsL = fmap varE tyFieldNamesL - let tyFieldVarsR = fmap varE tyFieldNamesR - let strategyFieldPats = replicate (length strategyFields) wildP - let patsL = tyFieldPatsL ++ strategyFieldPats - let patsR = tyFieldPatsR ++ strategyFieldPats - let allWildcards = fmap (const wildP) $ tyFieldPatsL ++ strategyFieldPats - let eqCont l r cont = - [| - SomeTypeRep $l == SomeTypeRep $r - && $cont - |] - let eqExp = - foldl (\cont (l, r) -> eqCont l r cont) (conE 'True) $ - zip tyFieldVarsL tyFieldVarsR - eqClause <- - clause - [conP newConName patsL, conP newConName patsR] - (normalB eqExp) - [] - let cmpCont l r cont = - [| - case SomeTypeRep $l `compare` SomeTypeRep $r of - EQ -> $cont - x -> x - |] - let cmpExp = - foldl (\cont (l, r) -> cmpCont l r cont) (conE 'EQ) $ - zip tyFieldVarsL tyFieldVarsR - cmpClause0 <- - clause - [conP newConName patsL, conP newConName patsR] - (normalB cmpExp) - [] - cmpClause1 <- - clause - [conP newConName allWildcards, wildP] - (normalB $ conE 'LT) - [] - cmpClause2 <- - clause - [wildP, conP newConName allWildcards] - (normalB $ conE 'GT) - [] - let cmpClauses = - if isLast - then [cmpClause0] - else [cmpClause0, cmpClause1, cmpClause2] - let showCont t cont = - [|$cont <> " " <> show $t|] - let showExp = foldl (flip showCont) (litE $ stringL conName) tyFieldVarsL - showClause <- - clause - [conP newConName patsL] - (normalB showExp) - [] - let ctx = applySubstitution substMap $ constructorContext con - let ctxAndGadtUsedVars = - S.fromList (freeVariables ctx) - <> S.fromList (freeVariables tyFields) - <> S.fromList (freeVariables strategyFields) - let isCtxAndGadtUsedVar nm = S.member nm ctxAndGadtUsedVars - return - ( ForallC - ( (`plainTVFlag` specifiedSpec) - <$> filter isCtxAndGadtUsedVar newNames - ) - ctx - $ GadtC - [newConName] - ( (Bang NoSourceUnpackedness NoSourceStrictness,) - <$> tyFields ++ strategyFields - ) - (ConT tyName), - newConName, - S.fromList [0 .. length tyFields - 1], - -- S.fromList $ fst <$> dedupedFields, - [eqClause], - cmpClauses, - [showClause] + let oriVars = dataTypeVars ++ constructorVars con + newDataTypeVars <- traverse (newName . nameBase . tvName) dataTypeVars + newConstructorVars <- + traverse (newName . nameBase . tvName) $ constructorVars con + let newNames = newDataTypeVars ++ newConstructorVars + -- newNames <- traverse (newName . nameBase . tvName) oriVars + let newVars = fmap VarT newNames + let substMap = M.fromList $ zip (tvName <$> oriVars) newVars + let fields = + zip [0 ..] $ + applySubstitution substMap $ + constructorFields con + let tyFields = + AppT (ConT ''TypeRep) + <$> applySubstitution + substMap + ((VarT . tvName) <$> constructorVars con) + let strategyFields = fmap (AppT (ConT ''MergingStrategy) . snd) fields + tyFieldNamesL <- traverse (const $ newName "p") tyFields + tyFieldNamesR <- traverse (const $ newName "p") tyFields + let tyFieldPatsL = fmap varP tyFieldNamesL + let tyFieldPatsR = fmap varP tyFieldNamesR + let tyFieldVarsL = fmap varE tyFieldNamesL + let tyFieldVarsR = fmap varE tyFieldNamesR + let strategyFieldPats = replicate (length strategyFields) wildP + let patsL = tyFieldPatsL ++ strategyFieldPats + let patsR = tyFieldPatsR ++ strategyFieldPats + let allWildcards = fmap (const wildP) $ tyFieldPatsL ++ strategyFieldPats + let eqCont l r cont = + [| + SomeTypeRep $l == SomeTypeRep $r + && $cont + |] + let eqExp = + foldl (\cont (l, r) -> eqCont l r cont) (conE 'True) $ + zip tyFieldVarsL tyFieldVarsR + eqClause <- + clause + [conP newConName patsL, conP newConName patsR] + (normalB eqExp) + [] + let cmpCont l r cont = + [| + case SomeTypeRep $l `compare` SomeTypeRep $r of + EQ -> $cont + x -> x + |] + let cmpExp = + foldl (\cont (l, r) -> cmpCont l r cont) (conE 'EQ) $ + zip tyFieldVarsL tyFieldVarsR + cmpClause0 <- + clause + [conP newConName patsL, conP newConName patsR] + (normalB cmpExp) + [] + cmpClause1 <- + clause + [conP newConName allWildcards, wildP] + (normalB $ conE 'LT) + [] + cmpClause2 <- + clause + [wildP, conP newConName allWildcards] + (normalB $ conE 'GT) + [] + let cmpClauses = + if isLast + then [cmpClause0] + else [cmpClause0, cmpClause1, cmpClause2] + let showCont t cont = + [|$cont <> " " <> show $t|] + let showExp = foldl (flip showCont) (litE $ stringL conName) tyFieldVarsL + showClause <- + clause + [conP newConName patsL] + (normalB showExp) + [] + let ctx = applySubstitution substMap $ constructorContext con + let ctxAndGadtUsedVars = + S.fromList (freeVariables ctx) + <> S.fromList (freeVariables tyFields) + <> S.fromList (freeVariables strategyFields) + let isCtxAndGadtUsedVar nm = S.member nm ctxAndGadtUsedVars + return + ( ForallC + ( (`plainTVFlag` specifiedSpec) + <$> filter isCtxAndGadtUsedVar newDataTypeVars ++ newConstructorVars ) + ctx + $ GadtC + [newConName] + ( (Bang NoSourceUnpackedness NoSourceStrictness,) + <$> tyFields ++ strategyFields + ) + (ConT tyName), + newConName, + [eqClause], + cmpClauses, + [showClause] + ) data MergingInfoResult = MergingInfoResult { _infoName :: Name, - _conInfoNames :: [Name], - _pos :: [S.Set Int] + _conInfoNames :: [Name] } genMergingInfo :: Name -> Q (MergingInfoResult, [Dec]) genMergingInfo typName = do d <- reifyDatatype typName - let originalName = occName $ datatypeName d + let originalName = mangleName $ datatypeName d let newName = originalName <> "MergingInfo" found <- lookupTypeName newName let constructors = datatypeCons d @@ -278,19 +252,18 @@ genMergingInfoCon (datatypeVars d) name True $ last constructors return $ cons0 ++ [consLast] - let cons = fmap (\(a, _, _, _, _, _) -> a) r + let cons = fmap (\(a, _, _, _, _) -> a) r let eqClauses = - concatMap (\(_, _, _, a, _, _) -> a) r + concatMap (\(_, _, a, _, _) -> a) r ++ [ Clause [WildP, WildP] (NormalB $ ConE 'False) [] | length constructors > 1 ] - let cmpClauses = concatMap (\(_, _, _, _, a, _) -> a) r - let showClauses = concatMap (\(_, _, _, _, _, a) -> a) r + let cmpClauses = concatMap (\(_, _, _, a, _) -> a) r + let showClauses = concatMap (\(_, _, _, _, a) -> a) r return ( MergingInfoResult name - (fmap (\(_, a, _, _, _, _) -> a) r) - (fmap (\(_, _, a, _, _, _) -> a) r), + (fmap (\(_, a, _, _, _) -> a) r), if isJust found then [] else @@ -315,107 +288,84 @@ -- | Generate 'Mergeable' instance and merging information for a GADT. genMergeableAndGetMergingInfoResult :: - Name -> Int -> Q (MergingInfoResult, [Dec]) -genMergeableAndGetMergingInfoResult typName n = do + DeriveConfig -> Name -> Int -> Q (MergingInfoResult, [Dec]) +genMergeableAndGetMergingInfoResult deriveConfig typName n = do (infoResult, infoDec) <- genMergingInfo typName - (_, decs) <- genMergeable' infoResult typName n + (_, decs) <- genMergeable' deriveConfig infoResult typName n return (infoResult, infoDec ++ decs) --- | Generate 'Mergeable' instance for a GADT. -genMergeable :: Name -> Int -> Q [Dec] -genMergeable typName n = do - (infoResult, infoDec) <- genMergingInfo typName - (_, decs) <- genMergeable' infoResult typName n - return $ infoDec ++ decs +constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp +constructMergingStrategyExp _ [] = [|SimpleStrategy $ \_ t _ -> t|] +constructMergingStrategyExp conInfo [x] = do + upname <- newName "a" + let unwrapPat = conP (constructorName conInfo) [varP upname] + let unwrapFun = lamE [unwrapPat] $ appE (varE 'unsafeCoerce) (varE upname) + [| + wrapStrategy + $(return x) + (unsafeCoerce . $(conE $ constructorName conInfo)) + $unwrapFun + |] +constructMergingStrategyExp conInfo (x : xs) = do + upnames <- replicateM (length xs + 1) $ newName "a" + let wrapPat1 [] = error "Should not happen" + wrapPat1 [x] = varP x + wrapPat1 (x : xs) = tupP [varP x, wrapPat1 xs] + let wrapped = foldl AppE (ConE $ constructorName conInfo) $ fmap VarE upnames + let wrapFun = + lamE + [varP $ head upnames, wrapPat1 $ tail upnames] + [|unsafeCoerce ($(return wrapped))|] + let unwrapPat = conP (constructorName conInfo) $ fmap varP upnames + let unwrapExp1 [] = error "Should not happen" + unwrapExp1 [_] = error "Should not happen" + unwrapExp1 [x, y] = + [|(unsafeCoerce $(varE x), unsafeCoerce $(varE y))|] + unwrapExp1 (x : xs) = [|(unsafeCoerce $(varE x), $(unwrapExp1 xs))|] + let unwrapFun = lamE [unwrapPat] (unwrapExp1 upnames) + let strategy1 [] = error "Should not happen" + strategy1 [x] = return x + strategy1 (x : xs) = + [| + product2Strategy + ((,)) + (\(x, y) -> (x, y)) + $(return x) + $(strategy1 xs) + |] + [| + product2Strategy + $wrapFun + $unwrapFun + $(return x) + $(strategy1 xs) + |] genMergeFunClause' :: Name -> ConstructorInfo -> Q Clause genMergeFunClause' conInfoName con = do let numExistential = length $ constructorVars con let numFields = length $ constructorFields con - let argWildCards = replicate numExistential wildP - case numFields of - 0 -> do - let pat = conP conInfoName [] - clause - (argWildCards ++ [pat]) - (normalB [|SimpleStrategy $ \_ t _ -> t|]) - [] - 1 -> do - pname <- newName "s" - upname <- newName "a" - let unwrapPat = conP (constructorName con) [varP upname] - let unwrapFun = lamE [unwrapPat] $ appE (varE 'unsafeCoerce) (varE upname) - clause - [conP conInfoName $ argWildCards ++ [varP pname]] - ( normalB - [| - wrapStrategy - $(varE pname) - (unsafeCoerce . $(conE $ constructorName con)) - $unwrapFun - |] - ) - [] - _ -> do - -- fail $ show (argWildCards, conInfoName) - pnames <- replicateM numFields $ newName "s" - upnames <- replicateM numFields $ newName "a" - let wrapPat1 [] = error "Should not happen" - wrapPat1 [x] = varP x - wrapPat1 (x : xs) = tupP [varP x, wrapPat1 xs] - let wrapped = foldl AppE (ConE $ constructorName con) $ fmap VarE upnames - let wrapFun = - lamE - [varP $ head upnames, wrapPat1 $ tail upnames] - [|unsafeCoerce ($(return wrapped))|] - let unwrapPat = conP (constructorName con) $ fmap varP upnames - let unwrapExp1 [] = error "Should not happen" - unwrapExp1 [_] = error "Should not happen" - unwrapExp1 [x, y] = - [|(unsafeCoerce $(varE x), unsafeCoerce $(varE y))|] - unwrapExp1 (x : xs) = [|(unsafeCoerce $(varE x), $(unwrapExp1 xs))|] - let unwrapFun = lamE [unwrapPat] (unwrapExp1 upnames) - let strategy1 [] = error "Should not happen" - strategy1 [x] = varE x - strategy1 (x : xs) = - [| - product2Strategy - ((,)) - (\(x, y) -> (x, y)) - $(varE x) - $(strategy1 xs) - |] - clause - ([conP conInfoName $ argWildCards ++ fmap varP pnames]) - ( normalB - [| - product2Strategy - $wrapFun - $unwrapFun - $(varE $ head pnames) - $(strategy1 $ tail pnames) - |] - ) - [] + let argWildCards = replicate numExistential wildP :: [Q Pat] + pnames <- replicateM numFields $ newName "s" + clause + ([conP conInfoName $ argWildCards ++ fmap varP pnames]) + (normalB (constructMergingStrategyExp con (map VarE pnames))) + [] + +constructVarPats :: ConstructorInfo -> Q Pat +constructVarPats conInfo = do + let fields = constructorFields conInfo + capture n = return $ SigP WildP $ fields !! n + conP (constructorName conInfo) $ capture <$> [0 .. length fields - 1] + genMergingInfoFunClause' :: - [Name] -> Name -> S.Set Int -> ConstructorInfo -> Q Clause -genMergingInfoFunClause' argTypes conInfoName pos oldCon = do - let conName = constructorName oldCon - let oldConVars = constructorVars oldCon - newNames <- traverse (newName . occName . tvName) oldConVars - let substMap = M.fromList $ zip (tvName <$> oldConVars) (VarT <$> newNames) - let con = applySubstitution substMap oldCon + [(Type, Kind)] -> Name -> ConstructorInfo -> Q Clause +genMergingInfoFunClause' argTypes conInfoName con = do let conVars = constructorVars con - let fields = constructorFields con - let capture n = - if S.member n pos - then do - return (SigP WildP $ fields !! n) - else return (WildP) capturedVarTyReps <- traverse (\bndr -> [|typeRep @($(varT $ tvName bndr))|]) conVars - varPat <- conP conName $ capture <$> [0 .. length (constructorFields con) - 1] + varPat <- constructVarPats con let infoExpWithTypeReps = foldl AppE (ConE conInfoName) capturedVarTyReps let fields = constructorFields con @@ -423,22 +373,32 @@ strategyNames <- traverse - ( \nm -> - if S.member nm usedArgs - then do - pname <- newName "p" - return (nm, Just pname) - else return (nm, Nothing) + ( \(ty, _) -> + case ty of + VarT nm -> + if S.member nm usedArgs + then do + pname <- newName "p" + return (nm, Just pname) + else return ('undefined, Nothing) + _ -> return ('undefined, Nothing) ) argTypes let argToStrategyPat = mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) strategyNames let strategyPats = fmap (maybe WildP VarP . snd) strategyNames - let argTypeSet = S.fromList argTypes + let argNameSet = + S.fromList $ + mapMaybe + ( \(ty, _) -> case ty of + VarT nm -> Just nm + _ -> Nothing + ) + argTypes let containsArg :: Type -> Bool containsArg ty = - S.intersection argTypeSet (S.fromList (freeVariables [ty])) /= S.empty + S.intersection argNameSet (S.fromList (freeVariables [ty])) /= S.empty let typeHasNoArg = not . containsArg let fieldStrategyExp ty = @@ -482,59 +442,266 @@ -- fail $ show infoExp return $ Clause (strategyPats ++ [varPat]) (NormalB infoExp) [] +mergeableFieldFunExp :: [Name] -> FieldFunExp +mergeableFieldFunExp unaryOpFunNames argToFunPat _ = go + where + go ty = do + let allArgNames = M.keysSet argToFunPat + let typeHasNoArg ty = + S.fromList (freeVariables [ty]) + `S.intersection` allArgNames + == S.empty + let fun0a a = [|$(varE $ head unaryOpFunNames) @($(return a))|] + fun1a a b = [|$(varE $ unaryOpFunNames !! 1) @($(return a)) $(go b)|] + fun2a a b c = + [| + $(varE $ unaryOpFunNames !! 2) + @($(return a)) + $(go b) + $(go c) + |] + fun3a a b c d = + [| + $(varE $ unaryOpFunNames !! 3) + @($(return a)) + $(go b) + $(go c) + $(go d) + |] + + case ty of + AppT (AppT (AppT a@(VarT _) b) c) d -> fun3a a b c d + AppT (AppT a@(VarT _) b) c -> fun2a a b c + AppT a@(VarT _) b -> fun1a a b + _ | typeHasNoArg ty -> fun0a ty + AppT a b | typeHasNoArg a -> fun1a a b + AppT (AppT a b) c | typeHasNoArg a -> fun2a a b c + AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3a a b c d + VarT nm -> case M.lookup nm argToFunPat of + Just pname -> varE pname + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + +mergeableNoExistentialConfig :: UnaryOpClassConfig +mergeableNoExistentialConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + MergeableNoExistentialConfig + { mergeableNoExistentialFun = + mergeableFieldFunExp + [ 'rootStrategy, + 'liftRootStrategy, + 'liftRootStrategy2, + 'liftRootStrategy3 + ] + } + [ 'rootStrategy, + 'liftRootStrategy, + 'liftRootStrategy2, + 'liftRootStrategy3 + ] + ], + unaryOpInstanceNames = + [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = False + } + +newtype MergeableNoExistentialConfig = MergeableNoExistentialConfig + { mergeableNoExistentialFun :: FieldFunExp + } + +instance UnaryOpFunConfig MergeableNoExistentialConfig where + genUnaryOpFun + _ + MergeableNoExistentialConfig {..} + funNames + n + _ + _ + argTypes + _ + constructors = do + allFields <- + mapM resolveTypeSynonyms $ + concatMap constructorFields constructors + let usedArgs = S.fromList $ freeVariables allFields + args <- + traverse + ( \(ty, _) -> do + case ty of + VarT nm -> + if S.member nm usedArgs + then do + pname <- newName "p" + return (nm, Just pname) + else return ('undefined, Nothing) + _ -> return ('undefined, Nothing) + ) + argTypes + let argToFunPat = + M.fromList $ mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) args + let funPats = fmap (maybe WildP VarP . snd) args + let genAuxFunExp conInfo = do + fields <- mapM resolveTypeSynonyms $ constructorFields conInfo + defaultFieldFunExps <- + traverse + (mergeableNoExistentialFun argToFunPat M.empty) + fields + constructMergingStrategyExp conInfo defaultFieldFunExps + auxExps <- mapM genAuxFunExp constructors + funExp <- case auxExps of + [] -> [|NoStrategy|] + [singleExp] -> return singleExp + _ -> do + p <- newName "p" + let numConstructors = length constructors + let getIdx i = + if numConstructors <= 2 + then if i == 0 then [|False|] else [|True|] + else integerE i + let getIdxPat i = + if numConstructors <= 2 + then conP (if i == 0 then 'False else 'True) [] + else do + let w8Bound = fromIntegral (maxBound @Word8) + let w16Bound = fromIntegral (maxBound @Word16) + let w32Bound = fromIntegral (maxBound @Word32) + let w64Bound = fromIntegral (maxBound @Word64) + sigP + (litP (integerL i)) + ( conT $ + if + | numConstructors <= w8Bound + 1 -> ''Word8 + | numConstructors <= w16Bound + 1 -> ''Word16 + | numConstructors <= w32Bound + 1 -> ''Word32 + | numConstructors <= w64Bound + 1 -> ''Word64 + | otherwise -> ''Integer + ) + let idxFun = + lamE [varP p] $ + caseE + (varE p) + ( zipWith + ( \conIdx conInfo -> do + match + (recP (constructorName conInfo) []) + (normalB (getIdx conIdx)) + [] + ) + [0 ..] + constructors + ) + let auxFun = + lamE [varP p] $ + caseE + (varE p) + ( zipWith + ( \conIdx exp -> do + match + (getIdxPat conIdx) + (normalB (return exp)) + [] + ) + [0 ..] + auxExps + ++ [match wildP (normalB [|undefined|]) []] + ) + [| + SortedStrategy $idxFun $auxFun + |] + let instanceFunName = funNames !! n + return $ + FunD + instanceFunName + [ Clause + funPats + (NormalB funExp) + [] + ] + -- | Generate 'Mergeable' instance for a GADT, using a given merging info -- result. -genMergeable' :: MergingInfoResult -> Name -> Int -> Q (Name, [Dec]) -genMergeable' (MergingInfoResult infoName conInfoNames pos) typName n = do - CheckArgsResult {..} <- checkArgs "Mergeable" 3 typName n +genMergeable' :: + DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec]) +genMergeable' deriveConfig (MergingInfoResult infoName conInfoNames) typName n = do + result@CheckArgsResult {..} <- + specializeResult (evalModeSpecializeList deriveConfig) + =<< checkArgs "Mergeable" 3 typName True n d <- reifyDatatype typName - let ctxForVar :: TyVarBndr_ flag -> Q (Maybe Pred) - ctxForVar var = case tvKind var of - StarT -> Just <$> [t|Mergeable $(varT $ tvName var)|] + let ctxForVar :: (Type, Kind) -> Q (Maybe Pred) + ctxForVar (ty, kind) = case kind of + StarT -> Just <$> [t|Mergeable $(return ty)|] AppT (AppT ArrowT StarT) StarT -> - Just <$> [t|Mergeable1 $(varT $ tvName var)|] + Just <$> [t|Mergeable1 $(return ty)|] AppT (AppT (AppT ArrowT StarT) StarT) StarT -> - Just <$> [t|Mergeable2 $(varT $ tvName var)|] + Just <$> [t|Mergeable2 $(return ty)|] AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) StarT -> - Just <$> [t|Mergeable3 $(varT $ tvName var)|] + Just <$> [t|Mergeable3 $(return ty)|] AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) _ -> - fail $ "Unsupported kind: " <> show (tvKind var) + fail $ "Unsupported kind: " <> show kind _ -> return Nothing + let isTypeUsedInFields (VarT nm) = isVarUsedInFields result nm + isTypeUsedInFields _ = False mergeableContexts <- - traverse ctxForVar $ filter (isVarUsedInFields . tvName) keptNewVars + traverse ctxForVar $ filter (isTypeUsedInFields . fst) keptVars + let instanceName = + case n of + 0 -> ''Mergeable + 1 -> ''Mergeable1 + 2 -> ''Mergeable2 + 3 -> ''Mergeable3 + _ -> error "Unsupported n" + + let instanceHead = ConT instanceName + extraPreds <- + extraConstraint + deriveConfig + typName + instanceName + [] + keptVars + constructors + let targetType = foldl - (\ty nm -> AppT ty (VarT nm)) + (\ty (var, _) -> AppT ty var) (ConT typName) - (keptNewNames ++ argNewNames) + (keptVars ++ argVars) let infoType = ConT infoName let mergingInfoFunFinalType = AppT (AppT ArrowT targetType) infoType let mergingInfoFunTypeWithoutCtx = foldr - ((AppT . AppT ArrowT) . AppT (ConT ''MergingStrategy) . VarT) + (((AppT . AppT ArrowT) . AppT (ConT ''MergingStrategy)) . fst) mergingInfoFunFinalType - argNewNames + argVars let mergingInfoFunType = ForallT - (mapTVFlag (const specifiedSpec) <$> keptNewVars ++ argNewVars) - (catMaybes mergeableContexts) + ( mapMaybe + ( \(ty, knd) -> case ty of + VarT nm -> Just $ kindedTVSpecified nm knd + _ -> Nothing + ) + $ keptVars ++ argVars + ) + (extraPreds ++ catMaybes mergeableContexts) mergingInfoFunTypeWithoutCtx + let mangledName = mangleName (datatypeName d) let mergingInfoFunName = mkName $ "mergingInfo" <> (if n /= 0 then show n else "") - <> occName (datatypeName d) + <> mangledName let mergingInfoFunSigD = SigD mergingInfoFunName mergingInfoFunType clauses <- - traverse - ( \(conInfoName, pos, con) -> - genMergingInfoFunClause' (tvName <$> argNewVars) conInfoName pos con - ) - $ zip3 conInfoNames pos constructors + traverse (uncurry (genMergingInfoFunClause' argVars)) $ + zip conInfoNames constructors let mergingInfoFunDec = FunD mergingInfoFunName clauses let mergeFunType = @@ -543,22 +710,15 @@ mkName $ "merge" <> (if n /= 0 then show n else "") - <> occName (datatypeName d) + <> mangledName let mergeFunSigD = SigD mergeFunName mergeFunType mergeFunClauses <- zipWithM genMergeFunClause' conInfoNames constructors let mergeFunDec = FunD mergeFunName mergeFunClauses - let instanceHead = case n of - 0 -> ConT ''Mergeable - 1 -> ConT ''Mergeable1 - 2 -> ConT ''Mergeable2 - 3 -> ConT ''Mergeable3 - _ -> error "Unsupported n" - let instanceType = AppT instanceHead - (foldl AppT (ConT typName) $ fmap VarT keptNewNames) + (foldl AppT (ConT typName) $ fmap fst keptVars) let mergeInstanceFunName = case n of 0 -> 'rootStrategy @@ -585,30 +745,48 @@ return ( mergingInfoFunName, - [ mergingInfoFunSigD, + [ PragmaD (InlineP mergingInfoFunName Inline FunLike AllPhases), + mergingInfoFunSigD, mergingInfoFunDec, + PragmaD (InlineP mergeFunName Inline FunLike AllPhases), mergeFunSigD, mergeFunDec, InstanceD Nothing - (catMaybes mergeableContexts) + (extraPreds ++ catMaybes mergeableContexts) instanceType [FunD mergeInstanceFunName [mergeInstanceFunClause]] ] ) +-- | Generate 'Mergeable' instance for a GADT without existential variables. +genMergeableNoExistential :: DeriveConfig -> Name -> Int -> Q [Dec] +genMergeableNoExistential deriveConfig typName n = do + genUnaryOpClass deriveConfig mergeableNoExistentialConfig n typName + +-- | Generate 'Mergeable' instance for a GADT. +genMergeable :: DeriveConfig -> Name -> Int -> Q [Dec] +genMergeable deriveConfig typName n = do + hasExistential <- dataTypeHasExistential typName + if hasExistential + then do + (infoResult, infoDec) <- genMergingInfo typName + (_, decs) <- genMergeable' deriveConfig infoResult typName n + return $ infoDec ++ decs + else genMergeableNoExistential deriveConfig typName n + -- | Derive 'Mergeable' instance for GADT. -deriveGADTMergeable :: Name -> Q [Dec] -deriveGADTMergeable nm = genMergeable nm 0 +deriveGADTMergeable :: DeriveConfig -> Name -> Q [Dec] +deriveGADTMergeable deriveConfig nm = genMergeable deriveConfig nm 0 -- | Derive 'Mergeable1' instance for GADT. -deriveGADTMergeable1 :: Name -> Q [Dec] -deriveGADTMergeable1 nm = genMergeable nm 1 +deriveGADTMergeable1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTMergeable1 deriveConfig nm = genMergeable deriveConfig nm 1 -- | Derive 'Mergeable2' instance for GADT. -deriveGADTMergeable2 :: Name -> Q [Dec] -deriveGADTMergeable2 nm = genMergeable nm 2 +deriveGADTMergeable2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTMergeable2 deriveConfig nm = genMergeable deriveConfig nm 2 -- | Derive 'Mergeable3' instance for GADT. -deriveGADTMergeable3 :: Name -> Q [Dec] -deriveGADTMergeable3 nm = genMergeable nm 3 +deriveGADTMergeable3 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTMergeable3 deriveConfig nm = genMergeable deriveConfig nm 3 diff --git a/src/Grisette/Internal/TH/GADT/DeriveNFData.hs b/src/Grisette/Internal/TH/GADT/DeriveNFData.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveNFData.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveNFData +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveNFData + ( deriveGADTNFData, + deriveGADTNFData1, + deriveGADTNFData2, + ) +where + +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), NFData2 (liftRnf2)) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + defaultFieldFunExp, + defaultFieldResFun, + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Language.Haskell.TH (Dec, Name) +import Language.Haskell.TH.Syntax (Q) + +nfdataConfig :: UnaryOpClassConfig +nfdataConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = [], + extraLiftedPatNames = const [], + fieldCombineFun = \_ _ _ _ exps -> do + r <- + foldl + (\acc exp -> [|$acc `seq` $(return exp)|]) + ([|()|]) + exps + return (r, []), + fieldResFun = defaultFieldResFun, + fieldFunExp = defaultFieldFunExp ['rnf, 'liftRnf, 'liftRnf2] + } + ['rnf, 'liftRnf, 'liftRnf2] + ], + unaryOpInstanceNames = [''NFData, ''NFData1, ''NFData2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } + +-- | Derive 'NFData' instance for a GADT. +deriveGADTNFData :: DeriveConfig -> Name -> Q [Dec] +deriveGADTNFData deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 0 + +-- | Derive 'NFData1' instance for a GADT. +deriveGADTNFData1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTNFData1 deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 1 + +-- | Derive 'NFData2' instance for a GADT. +deriveGADTNFData2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTNFData2 deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveOrd.hs b/src/Grisette/Internal/TH/GADT/DeriveOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveOrd.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveOrd + ( deriveGADTOrd, + deriveGADTOrd1, + deriveGADTOrd2, + ) +where + +import Data.Functor.Classes (Ord1 (liftCompare), Ord2 (liftCompare2)) +import Grisette.Internal.TH.GADT.BinaryOpCommon + ( BinaryOpClassConfig + ( BinaryOpClassConfig, + binaryOpAllowSumType, + binaryOpFieldConfigs, + binaryOpInstanceNames + ), + BinaryOpFieldConfig + ( BinaryOpFieldConfig, + extraPatNames, + fieldCombineFun, + fieldDifferentExistentialFun, + fieldFunExp, + fieldFunNames, + fieldLMatchResult, + fieldRMatchResult, + fieldResFun + ), + binaryOpAllowExistential, + defaultFieldFunExp, + genBinaryOpClass, + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Language.Haskell.TH (Dec, Exp (ListE), Name, Q) + +ordConfig :: BinaryOpClassConfig +ordConfig = + BinaryOpClassConfig + { binaryOpFieldConfigs = + [ BinaryOpFieldConfig + { extraPatNames = [], + fieldResFun = \_ (lhs, rhs) f -> + (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], + fieldCombineFun = \_ lst -> + (,[]) <$> [|mconcat $(return $ ListE lst)|], + fieldDifferentExistentialFun = return, + fieldFunExp = + defaultFieldFunExp ['compare, 'liftCompare, 'liftCompare2], + fieldFunNames = ['compare, 'liftCompare, 'liftCompare2], + fieldLMatchResult = [|LT|], + fieldRMatchResult = [|GT|] + } + ], + binaryOpInstanceNames = [''Ord, ''Ord1, ''Ord2], + binaryOpAllowSumType = True, + binaryOpAllowExistential = True + } + +-- | Derive 'Ord' instance for a GADT. +deriveGADTOrd :: DeriveConfig -> Name -> Q [Dec] +deriveGADTOrd deriveConfig = genBinaryOpClass deriveConfig ordConfig 0 + +-- | Derive 'Ord1' instance for a GADT. +deriveGADTOrd1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTOrd1 deriveConfig = genBinaryOpClass deriveConfig ordConfig 1 + +-- | Derive 'Ord2' instance for a GADT. +deriveGADTOrd2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTOrd2 deriveConfig = genBinaryOpClass deriveConfig ordConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DerivePPrint.hs b/src/Grisette/Internal/TH/GADT/DerivePPrint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DerivePPrint.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DerivePPrint +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DerivePPrint + ( deriveGADTPPrint, + deriveGADTPPrint1, + deriveGADTPPrint2, + ) +where + +import Data.Maybe (fromMaybe) +import Data.String (IsString (fromString)) +import GHC.Show (appPrec1) +import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint + ( PPrint (pformatList, pformatPrec), + PPrint1 (liftPFormatList, liftPFormatPrec), + PPrint2 (liftPFormatList2, liftPFormatPrec2), + align, + condEnclose, + flatAlt, + group, + groupedEnclose, + nest, + pformatWithConstructorNoAlign, + vcat, + vsep, + (<+>), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.ShowPPrintCommon (showPrintFieldFunExp) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Grisette.Internal.TH.Util (integerE, isNonUnitTuple) +import Language.Haskell.TH + ( Dec, + Exp (ListE), + Fixity (Fixity), + Name, + defaultFixity, + listE, + nameBase, + stringE, + ) +import Language.Haskell.TH.Datatype + ( ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor), + reifyFixityCompat, + ) +import Language.Haskell.TH.Syntax (Q) + +pprintConfig :: UnaryOpClassConfig +pprintConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = ["prec"], + extraLiftedPatNames = \i -> (["pl" | i /= 0]), + fieldCombineFun = \_ variant conName [prec] exps -> do + let initExps = + (\e -> [|$(return e) <> "," <> flatAlt "" " "|]) + <$> init exps + lastExp = [|$(return $ last exps)|] + commaSeped = initExps ++ [lastExp] + case (variant, exps) of + (NormalConstructor, []) -> do + r <- [|fromString $(stringE $ nameBase conName)|] + return (r, [False]) + (NormalConstructor, [exp]) -> do + r <- + [| + pformatWithConstructorNoAlign + $(return prec) + $(stringE $ nameBase conName) + [$(return exp)] + |] + return (r, [True]) + (NormalConstructor, _) | isNonUnitTuple conName -> do + r <- [|groupedEnclose "(" ")" $ vcat $ $(listE commaSeped)|] + return (r, [False]) + (NormalConstructor, _) -> do + r <- + [| + pformatWithConstructorNoAlign + $(return prec) + $(stringE $ nameBase conName) + [vsep $(return $ ListE exps)] + |] + return (r, [True]) + (RecordConstructor _, _) -> do + r <- + [| + pformatWithConstructorNoAlign + $(return prec) + $(stringE $ nameBase conName) + [groupedEnclose "{" "}" $ vcat $ $(listE commaSeped)] + |] + return (r, [True]) + (InfixConstructor, [l, r]) -> do + fi <- + fromMaybe defaultFixity `fmap` reifyFixityCompat conName + let conPrec = case fi of Fixity prec _ -> prec + r <- + [| + group + $ condEnclose + ($(return prec) > $(integerE conPrec)) + "(" + ")" + $ nest 2 + $ vsep + [ align $ $(return l), + fromString $(stringE $ nameBase conName) + <+> $(return r) + ] + |] + return (r, [True]) + _ -> + fail "deriveGADTPPrint: unexpected constructor variant", + fieldResFun = \variant conName _ pos fieldPat fieldFun -> do + let makePPrintField p = + [| + $(return fieldFun) + $(integerE p) + $(return fieldPat) + |] + let attachUsedInfo = ((,[False]) <$>) + case variant of + NormalConstructor + | isNonUnitTuple conName -> + attachUsedInfo $ makePPrintField 0 + NormalConstructor -> + attachUsedInfo $ makePPrintField appPrec1 + RecordConstructor names -> + attachUsedInfo + [| + fromString $(stringE $ nameBase (names !! pos) ++ " = ") + <> $(makePPrintField 0) + |] + InfixConstructor -> do + fi <- + fromMaybe defaultFixity `fmap` reifyFixityCompat conName + let conPrec = case fi of Fixity prec _ -> prec + attachUsedInfo $ makePPrintField (conPrec + 1), + fieldFunExp = + showPrintFieldFunExp + ['pformatPrec, 'liftPFormatPrec, 'liftPFormatPrec2] + ['pformatList, 'liftPFormatList, 'liftPFormatList2] + } + ['pformatPrec, 'liftPFormatPrec, 'liftPFormatPrec2] + ], + unaryOpExtraVars = const $ return [], + unaryOpInstanceNames = [''PPrint, ''PPrint1, ''PPrint2], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } + +-- | Derive 'PPrint' instance for a GADT. +deriveGADTPPrint :: DeriveConfig -> Name -> Q [Dec] +deriveGADTPPrint deriveConfig = genUnaryOpClass deriveConfig pprintConfig 0 + +-- | Derive 'PPrint1' instance for a GADT. +deriveGADTPPrint1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTPPrint1 deriveConfig = genUnaryOpClass deriveConfig pprintConfig 1 + +-- | Derive 'PPrint2' instance for a GADT. +deriveGADTPPrint2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTPPrint2 deriveConfig = genUnaryOpClass deriveConfig pprintConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveSerial.hs b/src/Grisette/Internal/TH/GADT/DeriveSerial.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveSerial.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveSerial +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveSerial + ( deriveGADTSerial, + deriveGADTSerial1, + deriveGADTSerial2, + ) +where + +import Control.Monad (zipWithM) +import Data.Bytes.Serial + ( Serial (deserialize, serialize), + Serial1 (deserializeWith, serializeWith), + Serial2 (deserializeWith2, serializeWith2), + ) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Set as S +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( FieldFunExp, + UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + UnaryOpFunConfig (genUnaryOpFun), + defaultFieldFunExp, + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Grisette.Internal.TH.Util (integerE) +import Language.Haskell.TH + ( Body (NormalB), + Clause (Clause), + Dec (FunD), + Lit (IntegerL), + Match (Match), + Name, + Pat (LitP, VarP, WildP), + Q, + Type (VarT), + bindS, + caseE, + conE, + conT, + doE, + match, + mkName, + newName, + noBindS, + normalB, + sigP, + varE, + varP, + wildP, + ) +import Language.Haskell.TH.Datatype + ( ConstructorInfo (constructorFields, constructorName), + TypeSubstitution (freeVariables), + resolveTypeSynonyms, + ) + +newtype UnaryOpDeserializeConfig = UnaryOpDeserializeConfig + {fieldDeserializeFun :: FieldFunExp} + +instance UnaryOpFunConfig UnaryOpDeserializeConfig where + genUnaryOpFun + _ + UnaryOpDeserializeConfig {..} + funNames + n + _ + _ + argTypes + _ + constructors = do + allFields <- + mapM resolveTypeSynonyms $ + concatMap constructorFields constructors + let usedArgs = S.fromList $ freeVariables allFields + args <- + traverse + ( \(ty, _) -> do + case ty of + VarT nm -> + if S.member nm usedArgs + then do + pname <- newName "p" + return (nm, Just pname) + else return ('undefined, Nothing) + _ -> return ('undefined, Nothing) + ) + argTypes + let argToFunPat = + M.fromList $ mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) args + let funPats = fmap (maybe WildP VarP . snd) args + let genAuxFunMatch conIdx conInfo = do + fields <- mapM resolveTypeSynonyms $ constructorFields conInfo + defaultFieldFunExps <- + traverse + (fieldDeserializeFun argToFunPat M.empty) + fields + let conName = constructorName conInfo + exp <- + foldl + (\exp fieldFun -> [|$exp <*> $(return fieldFun)|]) + [|return $(conE conName)|] + defaultFieldFunExps + return $ Match (LitP (IntegerL conIdx)) (NormalB exp) [] + auxMatches <- zipWithM genAuxFunMatch [0 ..] constructors + auxFallbackMatch <- match wildP (normalB [|undefined|]) [] + let instanceFunName = funNames !! n + -- let auxFunName = mkName "go" + let selName = mkName "sel" + exp <- + doE + [ bindS + (sigP (varP selName) (conT ''Int)) + [|deserialize|], + noBindS $ + caseE (varE selName) $ + return <$> auxMatches ++ [auxFallbackMatch] + ] + return $ + FunD + instanceFunName + [ Clause + funPats + (NormalB exp) + [] + ] + +serialConfig :: UnaryOpClassConfig +serialConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = [], + extraLiftedPatNames = const [], + fieldCombineFun = \conIdx _ _ [] exp -> do + r <- + foldl + (\r exp -> [|$r >> $(return exp)|]) + ([|serialize ($(integerE conIdx) :: Int)|]) + exp + return (r, [True]), + fieldResFun = \_ _ _ _ fieldPat fieldFun -> do + r <- [|$(return fieldFun) $(return fieldPat)|] + return (r, [True]), + fieldFunExp = + defaultFieldFunExp + ['serialize, 'serializeWith, 'serializeWith2] + } + ['serialize, 'serializeWith, 'serializeWith2], + UnaryOpConfig + UnaryOpDeserializeConfig + { fieldDeserializeFun = + defaultFieldFunExp + ['deserialize, 'deserializeWith, 'deserializeWith2] + } + ['deserialize, 'deserializeWith, 'deserializeWith2] + ], + unaryOpInstanceNames = [''Serial, ''Serial1, ''Serial2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = False + } + +-- | Derive 'Serial' instance for a GADT. +deriveGADTSerial :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSerial deriveConfig = genUnaryOpClass deriveConfig serialConfig 0 + +-- | Derive 'Serial1' instance for a GADT. +deriveGADTSerial1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSerial1 deriveConfig = genUnaryOpClass deriveConfig serialConfig 1 + +-- | Derive 'Serial2' instance for a GADT. +deriveGADTSerial2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSerial2 deriveConfig = genUnaryOpClass deriveConfig serialConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveShow.hs b/src/Grisette/Internal/TH/GADT/DeriveShow.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveShow.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveShow +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveShow + ( deriveGADTShow, + deriveGADTShow1, + deriveGADTShow2, + ) +where + +import Data.Functor.Classes + ( Show1 (liftShowList, liftShowsPrec), + Show2 (liftShowList2, liftShowsPrec2), + ) +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import GHC.Show (appPrec, appPrec1) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.ShowPPrintCommon (showPrintFieldFunExp) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Grisette.Internal.TH.Util (integerE, isNonUnitTuple) +import Language.Haskell.TH + ( Dec, + Fixity (Fixity), + Name, + Q, + defaultFixity, + integerL, + listE, + litE, + nameBase, + stringE, + ) +import Language.Haskell.TH.Datatype + ( ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor), + reifyFixityCompat, + ) + +showConfig :: UnaryOpClassConfig +showConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = ["prec"], + extraLiftedPatNames = \i -> (["sl" | i /= 0]), + fieldCombineFun = + \_ variant conName [prec] exps -> do + case (variant, exps) of + (NormalConstructor, []) -> do + r <- [|showString $(stringE $ nameBase conName)|] + return (r, [False]) + (NormalConstructor, [exp]) -> do + r <- + [| + showParen + ($(return prec) > $(integerE appPrec)) + ( showString $(stringE $ nameBase conName) + . showChar ' ' + . $(return exp) + ) + |] + return (r, [True]) + (NormalConstructor, _) | isNonUnitTuple conName -> do + let commaSeped = + List.intersperse [|showChar ','|] $ + return <$> exps + r <- + [| + showChar '(' + . foldr1 (.) $(listE commaSeped) + . showChar ')' + |] + return (r, [False]) + (NormalConstructor, _) -> do + let spaceSeped = + List.intersperse [|showChar ' '|] $ + return <$> exps + r <- + [| + showParen + ($(return prec) > $(integerE appPrec)) + ( showString $(stringE $ nameBase conName) + . showChar ' ' + . (foldr1 (.) $(listE spaceSeped)) + ) + |] + return (r, [True]) + (RecordConstructor _, _) -> do + let commaSpaceSeped = + List.intersperse [|showString ", "|] $ + return <$> exps + r <- + [| + showString $(stringE $ nameBase conName) + . showString " {" + . foldr1 (.) $(listE commaSpaceSeped) + . showString "}" + |] + return (r, [False]) + (InfixConstructor, [l, r]) -> do + fi <- + fromMaybe defaultFixity `fmap` reifyFixityCompat conName + let conPrec = case fi of Fixity prec _ -> prec + r <- + [| + showParen + ($(return prec) > $(integerE conPrec)) + ( $(return l) + . showChar ' ' + . showString $(stringE $ nameBase conName) + . showChar ' ' + . $(return r) + ) + |] + return (r, [True]) + _ -> + fail "deriveGADTShow: unexpected constructor variant", + fieldResFun = \variant conName _ pos fieldPat fieldFun -> do + let makeShowField p = + [| + $(return fieldFun) + $(litE $ integerL $ fromIntegral p) + $(return fieldPat) + |] + let attachUsedInfo = ((,[False]) <$>) + case variant of + NormalConstructor + | isNonUnitTuple conName -> + attachUsedInfo $ makeShowField 0 + NormalConstructor -> + attachUsedInfo $ makeShowField appPrec1 + RecordConstructor names -> + attachUsedInfo + [| + showString $(stringE $ nameBase (names !! pos) ++ " = ") + . $(makeShowField 0) + |] + InfixConstructor -> do + fi <- + fromMaybe defaultFixity `fmap` reifyFixityCompat conName + let conPrec = case fi of Fixity prec _ -> prec + attachUsedInfo $ makeShowField (conPrec + 1), + fieldFunExp = + showPrintFieldFunExp + ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2] + ['showList, 'liftShowList, 'liftShowList2] + } + ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2] + ], + unaryOpInstanceNames = [''Show, ''Show1, ''Show2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } + +-- | Derive 'Show' instance for a GADT. +deriveGADTShow :: DeriveConfig -> Name -> Q [Dec] +deriveGADTShow deriveConfig = genUnaryOpClass deriveConfig showConfig 0 + +-- | Derive 'Show1' instance for a GADT. +deriveGADTShow1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTShow1 deriveConfig = genUnaryOpClass deriveConfig showConfig 1 + +-- | Derive 'Show2' instance for a GADT. +deriveGADTShow2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTShow2 deriveConfig = genUnaryOpClass deriveConfig showConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveSimpleMergeable.hs b/src/Grisette/Internal/TH/GADT/DeriveSimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveSimpleMergeable.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveSimpleMergeable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveSimpleMergeable + ( deriveGADTSimpleMergeable, + deriveGADTSimpleMergeable1, + deriveGADTSimpleMergeable2, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + SimpleMergeable2 (liftMrgIte2), + ) +import Grisette.Internal.TH.GADT.BinaryOpCommon + ( BinaryOpClassConfig + ( BinaryOpClassConfig, + binaryOpAllowSumType, + binaryOpFieldConfigs, + binaryOpInstanceNames + ), + BinaryOpFieldConfig + ( BinaryOpFieldConfig, + extraPatNames, + fieldCombineFun, + fieldDifferentExistentialFun, + fieldFunExp, + fieldFunNames, + fieldLMatchResult, + fieldRMatchResult, + fieldResFun + ), + binaryOpAllowExistential, + defaultFieldFunExp, + genBinaryOpClass, + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Language.Haskell.TH (Dec, Exp (AppE, ConE), Name, Q) + +simpleMergeableConfig :: BinaryOpClassConfig +simpleMergeableConfig = + BinaryOpClassConfig + { binaryOpFieldConfigs = + [ BinaryOpFieldConfig + { extraPatNames = ["c"], + fieldResFun = \[c] (lhs, rhs) f -> + (,[True]) + <$> [|$(return f) $(return c) $(return lhs) $(return rhs)|], + fieldCombineFun = + \con lst -> return (foldl AppE (ConE con) lst, [False]), + fieldDifferentExistentialFun = const [|undefined|], + fieldFunExp = + defaultFieldFunExp ['mrgIte, 'liftMrgIte, 'liftMrgIte2], + fieldFunNames = ['mrgIte, 'liftMrgIte, 'liftMrgIte2], + fieldLMatchResult = [|undefined|], + fieldRMatchResult = [|undefined|] + } + ], + binaryOpInstanceNames = + [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2], + binaryOpAllowSumType = False, + binaryOpAllowExistential = True + } + +-- | Derive 'SimpleMergeable' instance for a GADT. +deriveGADTSimpleMergeable :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSimpleMergeable deriveConfig = + genBinaryOpClass deriveConfig simpleMergeableConfig 0 + +-- | Derive 'SimpleMergeable1' instance for a GADT. +deriveGADTSimpleMergeable1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSimpleMergeable1 deriveConfig = + genBinaryOpClass deriveConfig simpleMergeableConfig 1 + +-- | Derive 'SimpleMergeable2' instance for a GADT. +deriveGADTSimpleMergeable2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSimpleMergeable2 deriveConfig = + genBinaryOpClass deriveConfig simpleMergeableConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveSubstSym.hs b/src/Grisette/Internal/TH/GADT/DeriveSubstSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveSubstSym.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveSubstSym +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveSubstSym + ( deriveGADTSubstSym, + deriveGADTSubstSym1, + deriveGADTSubstSym2, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym + ( SubstSym (substSym), + SubstSym1 (liftSubstSym), + SubstSym2 (liftSubstSym2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + UnaryOpFieldConfig + ( UnaryOpFieldConfig, + extraLiftedPatNames, + extraPatNames, + fieldCombineFun, + fieldFunExp, + fieldResFun + ), + defaultFieldFunExp, + defaultFieldResFun, + defaultUnaryOpInstanceTypeFromConfig, + genUnaryOpClass, + ) +import Language.Haskell.TH (Dec, Exp (AppE, ConE), Name) +import Language.Haskell.TH.Syntax (Q) + +substSymConfig :: UnaryOpClassConfig +substSymConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpFieldConfig + { extraPatNames = ["symbol", "newVal"], + extraLiftedPatNames = const [], + fieldResFun = defaultFieldResFun, + fieldCombineFun = \_ _ con extraPat exp -> + return (foldl AppE (ConE con) exp, False <$ extraPat), + fieldFunExp = + defaultFieldFunExp + ['substSym, 'liftSubstSym, 'liftSubstSym2] + } + ['substSym, 'liftSubstSym, 'liftSubstSym2] + ], + unaryOpInstanceNames = + [''SubstSym, ''SubstSym1, ''SubstSym2], + unaryOpExtraVars = const $ return [], + unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, + unaryOpAllowExistential = True + } + +-- | Derive 'SubstSym' instance for a GADT. +deriveGADTSubstSym :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSubstSym deriveConfig = genUnaryOpClass deriveConfig substSymConfig 0 + +-- | Derive 'SubstSym1' instance for a GADT. +deriveGADTSubstSym1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSubstSym1 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 1 + +-- | Derive 'SubstSym2' instance for a GADT. +deriveGADTSubstSym2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSubstSym2 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveSymEq.hs b/src/Grisette/Internal/TH/GADT/DeriveSymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveSymEq.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveSymEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveSymEq + ( deriveGADTSymEq, + deriveGADTSymEq1, + deriveGADTSymEq2, + ) +where + +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (false, true, (.&&)), + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq + ( SymEq ((.==)), + SymEq1 (liftSymEq), + SymEq2 (liftSymEq2), + ) +import Grisette.Internal.TH.GADT.BinaryOpCommon + ( BinaryOpClassConfig + ( BinaryOpClassConfig, + binaryOpAllowSumType, + binaryOpFieldConfigs, + binaryOpInstanceNames + ), + BinaryOpFieldConfig + ( BinaryOpFieldConfig, + extraPatNames, + fieldCombineFun, + fieldDifferentExistentialFun, + fieldFunExp, + fieldFunNames, + fieldLMatchResult, + fieldRMatchResult, + fieldResFun + ), + binaryOpAllowExistential, + defaultFieldFunExp, + genBinaryOpClass, + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Language.Haskell.TH (Dec, Exp (ListE), Name, Q) + +symEqConfig :: BinaryOpClassConfig +symEqConfig = + BinaryOpClassConfig + { binaryOpFieldConfigs = + [ BinaryOpFieldConfig + { extraPatNames = [], + fieldResFun = \_ (lhs, rhs) f -> + (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], + fieldCombineFun = + \_ lst -> (,[]) <$> [|foldl (.&&) true $(return $ ListE lst)|], + fieldDifferentExistentialFun = const [|false|], + fieldFunExp = + defaultFieldFunExp ['(.==), 'liftSymEq, 'liftSymEq2], + fieldFunNames = ['(.==), 'liftSymEq, 'liftSymEq2], + fieldLMatchResult = [|false|], + fieldRMatchResult = [|false|] + } + ], + binaryOpInstanceNames = [''SymEq, ''SymEq1, ''SymEq2], + binaryOpAllowSumType = True, + binaryOpAllowExistential = True + } + +-- | Derive 'SymEq' instance for a GADT. +deriveGADTSymEq :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSymEq deriveConfig = genBinaryOpClass deriveConfig symEqConfig 0 + +-- | Derive 'SymEq1' instance for a GADT. +deriveGADTSymEq1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSymEq1 deriveConfig = genBinaryOpClass deriveConfig symEqConfig 1 + +-- | Derive 'SymEq2' instance for a GADT. +deriveGADTSymEq2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSymEq2 deriveConfig = genBinaryOpClass deriveConfig symEqConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveSymOrd.hs b/src/Grisette/Internal/TH/GADT/DeriveSymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveSymOrd.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveSymOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveSymOrd + ( deriveGADTSymOrd, + deriveGADTSymOrd1, + deriveGADTSymOrd2, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd + ( SymOrd (symCompare), + SymOrd1 (liftSymCompare), + SymOrd2 (liftSymCompare2), + ) +import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge + ( mrgSingle, + ) +import Grisette.Internal.TH.GADT.BinaryOpCommon + ( BinaryOpClassConfig + ( BinaryOpClassConfig, + binaryOpAllowSumType, + binaryOpFieldConfigs, + binaryOpInstanceNames + ), + BinaryOpFieldConfig + ( BinaryOpFieldConfig, + extraPatNames, + fieldCombineFun, + fieldDifferentExistentialFun, + fieldFunExp, + fieldFunNames, + fieldLMatchResult, + fieldRMatchResult, + fieldResFun + ), + binaryOpAllowExistential, + defaultFieldFunExp, + genBinaryOpClass, + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Language.Haskell.TH (Dec, Name, Q) + +symOrdConfig :: BinaryOpClassConfig +symOrdConfig = + BinaryOpClassConfig + { binaryOpFieldConfigs = + [ BinaryOpFieldConfig + { extraPatNames = [], + fieldResFun = + \_ (lhs, rhs) f -> + (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], + fieldCombineFun = + \_ lst -> do + let go [] = [|mrgSingle EQ|] + go [x] = [|$(return x)|] + go (x : xs) = + [| + do + a <- $(return x) + case a of + EQ -> $(go xs) + _ -> mrgSingle a + |] + (,[]) <$> go lst, + fieldDifferentExistentialFun = + \exp -> [|mrgSingle $(return exp)|], + fieldFunExp = + defaultFieldFunExp + ['symCompare, 'liftSymCompare, 'liftSymCompare2], + fieldFunNames = ['symCompare, 'liftSymCompare, 'liftSymCompare2], + fieldLMatchResult = [|mrgSingle LT|], + fieldRMatchResult = [|mrgSingle GT|] + } + ], + binaryOpInstanceNames = [''SymOrd, ''SymOrd1, ''SymOrd2], + binaryOpAllowSumType = True, + binaryOpAllowExistential = True + } + +-- | Derive 'SymOrd' instance for a GADT. +deriveGADTSymOrd :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSymOrd deriveConfig = genBinaryOpClass deriveConfig symOrdConfig 0 + +-- | Derive 'SymOrd1' instance for a GADT. +deriveGADTSymOrd1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSymOrd1 deriveConfig = genBinaryOpClass deriveConfig symOrdConfig 1 + +-- | Derive 'SymOrd2' instance for a GADT. +deriveGADTSymOrd2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTSymOrd2 deriveConfig = genBinaryOpClass deriveConfig symOrdConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveToCon.hs b/src/Grisette/Internal/TH/GADT/DeriveToCon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveToCon.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveToCon +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveToCon + ( deriveGADTToCon, + deriveGADTToCon1, + deriveGADTToCon2, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon + ( ToCon (toCon), + ToCon1 (liftToCon), + ToCon2 (liftToCon2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.ConvertOpCommon + ( ConvertOpClassConfig + ( ConvertOpClassConfig, + convertFieldCombineFun, + convertFieldFunExp, + convertFieldResFun, + convertOpFunNames, + convertOpInstanceNames, + convertOpTarget + ), + defaultFieldFunExp, + genConvertOpClass, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C)) +import Language.Haskell.TH (Dec, Name, Q, conE) + +toConClassConfig :: ConvertOpClassConfig +toConClassConfig = + ConvertOpClassConfig + { convertFieldResFun = \v f -> [|$(return f) $(return v)|], + convertFieldCombineFun = \f args -> + foldl + (\acc arg -> [|$(acc) <*> $arg|]) + [|return $(conE f)|] + $ fmap return args, + convertFieldFunExp = defaultFieldFunExp ['toCon, 'liftToCon, 'liftToCon2], + convertOpTarget = C, + convertOpInstanceNames = [''ToCon, ''ToCon1, ''ToCon2], + convertOpFunNames = ['toCon, 'liftToCon, 'liftToCon2] + } + +-- | Derive 'ToCon' instance for a GADT. +deriveGADTToCon :: DeriveConfig -> Name -> Q [Dec] +deriveGADTToCon deriveConfig = genConvertOpClass deriveConfig toConClassConfig 0 + +-- | Derive 'ToCon1' instance for a GADT. +deriveGADTToCon1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTToCon1 deriveConfig = + genConvertOpClass deriveConfig toConClassConfig 1 + +-- | Derive 'ToCon2' instance for a GADT. +deriveGADTToCon2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTToCon2 deriveConfig = + genConvertOpClass deriveConfig toConClassConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveToSym.hs b/src/Grisette/Internal/TH/GADT/DeriveToSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveToSym.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveToSym +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveToSym + ( deriveGADTToSym, + deriveGADTToSym1, + deriveGADTToSym2, + ) +where + +import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym + ( ToSym (toSym), + ToSym1 (liftToSym), + ToSym2 (liftToSym2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig) +import Grisette.Internal.TH.GADT.ConvertOpCommon + ( ConvertOpClassConfig + ( ConvertOpClassConfig, + convertFieldCombineFun, + convertFieldFunExp, + convertFieldResFun, + convertOpInstanceNames, + convertOpTarget + ), + convertOpFunNames, + defaultFieldFunExp, + genConvertOpClass, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) +import Language.Haskell.TH (Dec, Name, Q, appE, conE) + +toSymClassConfig :: ConvertOpClassConfig +toSymClassConfig = + ConvertOpClassConfig + { convertFieldResFun = \v f -> [|$(return f) $(return v)|], + convertFieldCombineFun = + \f args -> foldl appE (conE f) $ fmap return args, + convertFieldFunExp = defaultFieldFunExp ['toSym, 'liftToSym, 'liftToSym2], + convertOpTarget = S, + convertOpInstanceNames = [''ToSym, ''ToSym1, ''ToSym2], + convertOpFunNames = ['toSym, 'liftToSym, 'liftToSym2] + } + +-- | Derive 'ToSym' instance for a GADT. +deriveGADTToSym :: DeriveConfig -> Name -> Q [Dec] +deriveGADTToSym deriveConfig = genConvertOpClass deriveConfig toSymClassConfig 0 + +-- | Derive 'ToSym1' instance for a GADT. +deriveGADTToSym1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTToSym1 deriveConfig = + genConvertOpClass deriveConfig toSymClassConfig 1 + +-- | Derive 'ToSym2' instance for a GADT. +deriveGADTToSym2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTToSym2 deriveConfig = + genConvertOpClass deriveConfig toSymClassConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveUnifiedSimpleMergeable.hs b/src/Grisette/Internal/TH/GADT/DeriveUnifiedSimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveUnifiedSimpleMergeable.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveUnifiedSimpleMergeable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveUnifiedSimpleMergeable + ( deriveGADTUnifiedSimpleMergeable, + deriveGADTUnifiedSimpleMergeable1, + deriveGADTUnifiedSimpleMergeable2, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable + ( UnifiedSimpleMergeable (withBaseSimpleMergeable), + UnifiedSimpleMergeable1 (withBaseSimpleMergeable1), + UnifiedSimpleMergeable2 (withBaseSimpleMergeable2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig (evalModeConfig)) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + genUnaryOpClass, + ) +import Grisette.Internal.TH.GADT.UnifiedOpCommon + ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun), + defaultUnaryOpUnifiedFun, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) +import Language.Haskell.TH + ( Dec, + Name, + Q, + Type (ConT, VarT), + appT, + conT, + newName, + ) + +unifiedSimpleMergeableConfig :: UnaryOpClassConfig +unifiedSimpleMergeableConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpUnifiedConfig + { unifiedFun = + defaultUnaryOpUnifiedFun + [ 'withBaseSimpleMergeable, + 'withBaseSimpleMergeable1, + 'withBaseSimpleMergeable2 + ] + } + [ 'withBaseSimpleMergeable, + 'withBaseSimpleMergeable1, + 'withBaseSimpleMergeable2 + ] + ], + unaryOpInstanceNames = + [ ''UnifiedSimpleMergeable, + ''UnifiedSimpleMergeable1, + ''UnifiedSimpleMergeable2 + ], + unaryOpExtraVars = \config -> do + let modeConfigs = evalModeConfig config + case modeConfigs of + [] -> do + nm <- newName "mode" + return [(VarT nm, ConT ''EvalModeTag)] + [_] -> return [] + _ -> fail "UnifiedSimpleMergeable does not support multiple evaluation modes", + unaryOpInstanceTypeFromConfig = + \config newModeVars keptNewVars con -> do + let modeConfigs = evalModeConfig config + modeVar <- case modeConfigs of + [] -> return $ head newModeVars + [(i, _)] -> do + if i >= length keptNewVars + then fail "UnifiedSimpleMergeable reference to a non-existent mode variable" + else return $ keptNewVars !! i + _ -> fail "UnifiedSimpleMergeable does not support multiple evaluation modes" + appT (conT con) (return $ fst modeVar), + unaryOpAllowExistential = True + } + +-- | Derive 'UnifiedSimpleMergeable' instance for a GADT. +deriveGADTUnifiedSimpleMergeable :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSimpleMergeable deriveConfig = + genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 0 + +-- | Derive 'UnifiedSimpleMergeable1' instance for a GADT. +deriveGADTUnifiedSimpleMergeable1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSimpleMergeable1 deriveConfig = + genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 1 + +-- | Derive 'UnifiedSimpleMergeable2' instance for a GADT. +deriveGADTUnifiedSimpleMergeable2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSimpleMergeable2 deriveConfig = + genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveUnifiedSymEq.hs b/src/Grisette/Internal/TH/GADT/DeriveUnifiedSymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveUnifiedSymEq.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveUnifiedSymEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveUnifiedSymEq + ( deriveGADTUnifiedSymEq, + deriveGADTUnifiedSymEq1, + deriveGADTUnifiedSymEq2, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq + ( UnifiedSymEq (withBaseSymEq), + UnifiedSymEq1 (withBaseSymEq1), + UnifiedSymEq2 (withBaseSymEq2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig (evalModeConfig)) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + genUnaryOpClass, + ) +import Grisette.Internal.TH.GADT.UnifiedOpCommon + ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun), + defaultUnaryOpUnifiedFun, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) +import Language.Haskell.TH + ( Dec, + Name, + Q, + Type (ConT, VarT), + appT, + conT, + newName, + ) + +unifiedSymEqConfig :: UnaryOpClassConfig +unifiedSymEqConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpUnifiedConfig + { unifiedFun = + defaultUnaryOpUnifiedFun + ['withBaseSymEq, 'withBaseSymEq1, 'withBaseSymEq2] + } + ['withBaseSymEq, 'withBaseSymEq1, 'withBaseSymEq2] + ], + unaryOpInstanceNames = [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2], + unaryOpExtraVars = \config -> do + let modeConfigs = evalModeConfig config + case modeConfigs of + [] -> do + nm <- newName "mode" + return [(VarT nm, ConT ''EvalModeTag)] + [_] -> return [] + _ -> fail "UnifiedSymEq does not support multiple evaluation modes", + unaryOpInstanceTypeFromConfig = + \config newModeVars keptNewVars con -> do + let modeConfigs = evalModeConfig config + modeVar <- case modeConfigs of + [] -> return $ head newModeVars + [(i, _)] -> do + if i >= length keptNewVars + then fail "UnifiedSymEq reference to a non-existent mode variable" + else return $ keptNewVars !! i + _ -> fail "UnifiedSymEq does not support multiple evaluation modes" + appT (conT con) (return $ fst modeVar), + unaryOpAllowExistential = True + } + +-- | Derive 'UnifiedSymEq' instance for a GADT. +deriveGADTUnifiedSymEq :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSymEq deriveConfig = + genUnaryOpClass deriveConfig unifiedSymEqConfig 0 + +-- | Derive 'UnifiedSymEq1' instance for a GADT. +deriveGADTUnifiedSymEq1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSymEq1 deriveConfig = + genUnaryOpClass deriveConfig unifiedSymEqConfig 1 + +-- | Derive 'UnifiedSymEq2' instance for a GADT. +deriveGADTUnifiedSymEq2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSymEq2 deriveConfig = + genUnaryOpClass deriveConfig unifiedSymEqConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/DeriveUnifiedSymOrd.hs b/src/Grisette/Internal/TH/GADT/DeriveUnifiedSymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/DeriveUnifiedSymOrd.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.DeriveUnifiedSymOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.DeriveUnifiedSymOrd + ( deriveGADTUnifiedSymOrd, + deriveGADTUnifiedSymOrd1, + deriveGADTUnifiedSymOrd2, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd + ( UnifiedSymOrd (withBaseSymOrd), + UnifiedSymOrd1 (withBaseSymOrd1), + UnifiedSymOrd2 (withBaseSymOrd2), + ) +import Grisette.Internal.TH.GADT.Common (DeriveConfig (evalModeConfig)) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpClassConfig + ( UnaryOpClassConfig, + unaryOpAllowExistential, + unaryOpConfigs, + unaryOpExtraVars, + unaryOpInstanceNames, + unaryOpInstanceTypeFromConfig + ), + UnaryOpConfig (UnaryOpConfig), + genUnaryOpClass, + ) +import Grisette.Internal.TH.GADT.UnifiedOpCommon + ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun), + defaultUnaryOpUnifiedFun, + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) +import Language.Haskell.TH + ( Dec, + Name, + Q, + Type (ConT, VarT), + appT, + conT, + newName, + ) + +unifiedSymOrdConfig :: UnaryOpClassConfig +unifiedSymOrdConfig = + UnaryOpClassConfig + { unaryOpConfigs = + [ UnaryOpConfig + UnaryOpUnifiedConfig + { unifiedFun = + defaultUnaryOpUnifiedFun + ['withBaseSymOrd, 'withBaseSymOrd1, 'withBaseSymOrd2] + } + ['withBaseSymOrd, 'withBaseSymOrd1, 'withBaseSymOrd2] + ], + unaryOpInstanceNames = [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2], + unaryOpExtraVars = \config -> do + let modeConfigs = evalModeConfig config + case modeConfigs of + [] -> do + nm <- newName "mode" + return [(VarT nm, ConT ''EvalModeTag)] + [_] -> return [] + _ -> fail "UnifiedSymOrd does not support multiple evaluation modes", + unaryOpInstanceTypeFromConfig = + \config newModeVars keptNewVars con -> do + let modeConfigs = evalModeConfig config + modeVar <- case modeConfigs of + [] -> return $ head newModeVars + [(i, _)] -> do + if i >= length keptNewVars + then fail "UnifiedSymOrd reference to a non-existent mode variable" + else return $ keptNewVars !! i + _ -> fail "UnifiedSymOrd does not support multiple evaluation modes" + appT (conT con) (return $ fst modeVar), + unaryOpAllowExistential = True + } + +-- | Derive 'UnifiedSymOrd' instance for a GADT. +deriveGADTUnifiedSymOrd :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSymOrd deriveConfig = + genUnaryOpClass deriveConfig unifiedSymOrdConfig 0 + +-- | Derive 'UnifiedSymOrd1' instance for a GADT. +deriveGADTUnifiedSymOrd1 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSymOrd1 deriveConfig = + genUnaryOpClass deriveConfig unifiedSymOrdConfig 1 + +-- | Derive 'UnifiedSymOrd2' instance for a GADT. +deriveGADTUnifiedSymOrd2 :: DeriveConfig -> Name -> Q [Dec] +deriveGADTUnifiedSymOrd2 deriveConfig = + genUnaryOpClass deriveConfig unifiedSymOrdConfig 2 diff --git a/src/Grisette/Internal/TH/GADT/ShowPPrintCommon.hs b/src/Grisette/Internal/TH/GADT/ShowPPrintCommon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/ShowPPrintCommon.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.ShowPPrintCommon +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.ShowPPrintCommon (showPrintFieldFunExp) where + +import qualified Data.Map as M +import qualified Data.Set as S +import Grisette.Internal.TH.GADT.UnaryOpCommon (FieldFunExp) +import Language.Haskell.TH (Name, Type (AppT, VarT), varE) +import Language.Haskell.TH.Datatype (TypeSubstitution (freeVariables)) + +-- | Common 'FieldFunExp' for 'Show' and 'Grisette.Core.PPrint' on a GADT. +showPrintFieldFunExp :: [Name] -> [Name] -> FieldFunExp +showPrintFieldFunExp precNames listNames argToFunPat liftedExps = go + where + allArgNames = M.keysSet argToFunPat + typeHasNoArg ty = + S.fromList (freeVariables [ty]) + `S.intersection` allArgNames + == S.empty + goLst ty = do + let fun0 = varE (head listNames) + fun1 b = [|$(varE $ listNames !! 1) $(go b) $(goLst b)|] + fun2 b c = + [|$(varE $ listNames !! 2) $(go b) $(goLst b) $(go c) $(goLst c)|] + case ty of + AppT (AppT (VarT _) b) c -> fun2 b c + AppT (VarT _) b -> fun1 b + _ | typeHasNoArg ty -> fun0 + AppT a b | typeHasNoArg a -> fun1 b + AppT (AppT a b) c | typeHasNoArg a -> fun2 b c + VarT nm -> case M.lookup nm liftedExps of + Just [p] -> varE p + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + go ty = do + let fun0 = varE (head precNames) + fun1 b = [|$(varE $ precNames !! 1) $(go b) $(goLst b)|] + fun2 b c = + [|$(varE $ precNames !! 2) $(go b) $(goLst b) $(go c) $(goLst c)|] + case ty of + AppT (AppT (VarT _) b) c -> fun2 b c + AppT (VarT _) b -> fun1 b + _ | typeHasNoArg ty -> fun0 + AppT a b | typeHasNoArg a -> fun1 b + AppT (AppT a b) c | typeHasNoArg a -> fun2 b c + VarT nm -> case M.lookup nm argToFunPat of + Just pname -> varE pname + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty diff --git a/src/Grisette/Internal/TH/GADT/UnaryOpCommon.hs b/src/Grisette/Internal/TH/GADT/UnaryOpCommon.hs --- a/src/Grisette/Internal/TH/GADT/UnaryOpCommon.hs +++ b/src/Grisette/Internal/TH/GADT/UnaryOpCommon.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Grisette.Internal.TH.GADT.UnaryOpCommon @@ -14,199 +16,356 @@ module Grisette.Internal.TH.GADT.UnaryOpCommon ( UnaryOpClassConfig (..), UnaryOpFieldConfig (..), - genUnaryOpClause, + UnaryOpConfig (..), + UnaryOpFunConfig (..), + FieldFunExp, + defaultFieldResFun, + defaultFieldFunExp, genUnaryOpClass, + defaultUnaryOpInstanceTypeFromConfig, ) where import Control.Monad (replicateM, zipWithM) +import qualified Data.List as List import qualified Data.Map as M import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Set as S import Grisette.Internal.TH.GADT.Common ( CheckArgsResult ( CheckArgsResult, - argNewNames, + argVars, constructors, - isVarUsedInFields, - keptNewNames, - keptNewVars + keptVars ), + DeriveConfig, checkArgs, + ctxForVar, + evalModeSpecializeList, + extraConstraint, + freshenCheckArgsResult, + isVarUsedInFields, + specializeResult, ) -import Grisette.Internal.TH.Util (occName) +import Grisette.Internal.TH.Util (allUsedNames) import Language.Haskell.TH ( Body (NormalB), Clause (Clause), Dec (FunD, InstanceD), - Exp (ConE), + Exp (VarE), + Kind, Name, Pat (VarP, WildP), - Pred, Q, - Type (AppT, ArrowT, ConT, StarT, VarT), + Type (AppT, ConT, VarT), appE, conP, conT, + nameBase, newName, varE, varP, - varT, ) import Language.Haskell.TH.Datatype - ( ConstructorInfo (constructorFields, constructorName), + ( ConstructorInfo (constructorFields, constructorName, constructorVariant), + ConstructorVariant, TypeSubstitution (freeVariables), - tvName, + resolveTypeSynonyms, ) -import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, tvKind) -fieldExp :: [Name] -> M.Map Name Name -> Type -> Q Exp -fieldExp unaryOpFunNames argToFunPat ty = do - let notContains = - M.null $ - M.restrictKeys argToFunPat (S.fromList $ freeVariables [ty]) - let allArgNames = M.keysSet argToFunPat - let typeHasNoArg ty = - S.fromList (freeVariables [ty]) `S.intersection` allArgNames == S.empty - if notContains - then varE $ head unaryOpFunNames - else case ty of - _ | typeHasNoArg ty -> [|$(varE $ head unaryOpFunNames)|] - AppT a b | typeHasNoArg a -> do - [| - $(varE $ unaryOpFunNames !! 1) - $(fieldExp unaryOpFunNames argToFunPat b) - |] - AppT (AppT a b) c - | typeHasNoArg a -> - [| - $(varE $ unaryOpFunNames !! 2) - $(fieldExp unaryOpFunNames argToFunPat b) - $(fieldExp unaryOpFunNames argToFunPat c) - |] - AppT (AppT (AppT a b) c) d - | typeHasNoArg a -> - [| - $(varE $ unaryOpFunNames !! 3) - $(fieldExp unaryOpFunNames argToFunPat b) - $(fieldExp unaryOpFunNames argToFunPat c) - $(fieldExp unaryOpFunNames argToFunPat d) - |] - VarT nm -> do - case M.lookup nm argToFunPat of +-- | Type of field function expression generator. +type FieldFunExp = M.Map Name Name -> M.Map Name [Name] -> Type -> Q Exp + +-- | Default field function expression generator. +defaultFieldFunExp :: [Name] -> FieldFunExp +defaultFieldFunExp unaryOpFunNames argToFunPat _ = go + where + go ty = do + let allArgNames = M.keysSet argToFunPat + let typeHasNoArg ty = + S.fromList (freeVariables [ty]) + `S.intersection` allArgNames + == S.empty + let fun0 = varE $ head unaryOpFunNames + fun1 b = [|$(varE $ unaryOpFunNames !! 1) $(go b)|] + fun2 b c = [|$(varE $ unaryOpFunNames !! 2) $(go b) $(go c)|] + fun3 b c d = + [|$(varE $ unaryOpFunNames !! 3) $(go b) $(go c) $(go d)|] + case ty of + AppT (AppT (AppT (VarT _) b) c) d -> fun3 b c d + AppT (AppT (VarT _) b) c -> fun2 b c + AppT (VarT _) b -> fun1 b + _ | typeHasNoArg ty -> fun0 + AppT a b | typeHasNoArg a -> fun1 b + AppT (AppT a b) c | typeHasNoArg a -> fun2 b c + AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3 b c d + VarT nm -> case M.lookup nm argToFunPat of Just pname -> varE pname - _ -> fail $ "fieldExp: unsupported type: " <> show ty - _ -> fail $ "fieldExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty + _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty -patAndExps :: - (M.Map Name Name -> Type -> Q Exp) -> [Name] -> [Type] -> Q ([Pat], [Exp]) -patAndExps fieldFunExpGen argTypes fields = do +-- | Configuration for a unary function field expression generation on a GADT. +data UnaryOpConfig where + UnaryOpConfig :: + (UnaryOpFunConfig config) => config -> [Name] -> UnaryOpConfig + +-- | Default field result function. +defaultFieldResFun :: + ConstructorVariant -> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool]) +defaultFieldResFun _ _ extraPatExps _ fieldPatExp defaultFieldFunExp = do + res <- + appE + ( foldl + (\exp name -> appE exp (return name)) + (return defaultFieldFunExp) + extraPatExps + ) + (return fieldPatExp) + return (res, (True <$ extraPatExps)) + +funPatAndExps :: + FieldFunExp -> + (Int -> [String]) -> + [(Type, Kind)] -> + [Type] -> + Q ([Pat], [[Pat]], [Exp]) +funPatAndExps fieldFunExpGen extraLiftedPatNames argTypes fields = do let usedArgs = S.fromList $ freeVariables fields + let liftedNames = extraLiftedPatNames (length argTypes) args <- traverse - ( \nm -> - if S.member nm usedArgs - then do - pname <- newName "p" - return (nm, Just pname) - else return (nm, Nothing) + ( \(ty, _) -> do + case ty of + VarT nm -> + if S.member nm usedArgs + then do + pname <- newName "p" + epname <- traverse newName liftedNames + return (nm, Just (pname, epname)) + else return ('undefined, Nothing) + _ -> return ('undefined, Nothing) ) argTypes - let argToFunPat = M.fromList $ mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) args - let funPats = fmap (maybe WildP VarP . snd) args - fieldEvalSymFunExps <- traverse (fieldFunExpGen argToFunPat) fields - return (funPats, fieldEvalSymFunExps) - --- | Configuration for a unary function field expression generation on a GADT. -data UnaryOpFieldConfig = UnaryOpFieldConfig - { extraPatNames :: [String], - fieldCombineFun :: Exp -> [Exp] -> Q Exp - } + let argToFunPat = + M.fromList $ mapMaybe (\(nm, mpat) -> fmap ((nm,) . fst) mpat) args + let argToLiftedPat = + M.fromList $ mapMaybe (\(nm, mpat) -> fmap ((nm,) . snd) mpat) args + let funPats = fmap (maybe WildP (VarP . fst) . snd) args + let extraLiftedPats = + fmap + ( maybe + (replicate (length liftedNames) WildP) + (fmap VarP . snd) + . snd + ) + args + defaultFieldFunExps <- + traverse + (fieldFunExpGen argToFunPat argToLiftedPat) + fields + return (funPats, extraLiftedPats, defaultFieldFunExps) -- | Generate a clause for a unary function on a GADT. -genUnaryOpClause :: - [Name] -> +genUnaryOpFieldClause :: UnaryOpFieldConfig -> - [Name] -> + [(Type, Kind)] -> + Int -> ConstructorInfo -> Q Clause -genUnaryOpClause - unaryOpFunNames +genUnaryOpFieldClause (UnaryOpFieldConfig {..}) argTypes + conIdx conInfo = do - let fields = constructorFields conInfo - (funPats, fieldFunExps) <- - patAndExps (fieldExp unaryOpFunNames) argTypes fields + fields <- mapM resolveTypeSynonyms $ constructorFields conInfo + (funPats, funLiftedPats, defaultFieldFunExps) <- + funPatAndExps fieldFunExp extraLiftedPatNames argTypes fields extraPatNames <- traverse newName extraPatNames + let extraPatExps = fmap VarE extraPatNames fieldsPatNames <- replicateM (length fields) $ newName "field" let extraPats = fmap VarP extraPatNames fieldPats <- conP (constructorName conInfo) (fmap varP fieldsPatNames) + let fieldPatExps = fmap VarE fieldsPatNames - fieldExps <- - zipWithM - ( \nm fun -> - appE - ( foldl - (\exp name -> appE exp (varE name)) - (return fun) - extraPatNames - ) - (varE nm) - ) - fieldsPatNames - fieldFunExps + fieldResExpsAndArgsUsed <- + sequence $ + zipWith3 + ( fieldResFun + (constructorVariant conInfo) + (constructorName conInfo) + extraPatExps + ) + [0 ..] + fieldPatExps + defaultFieldFunExps + let fieldResExps = fst <$> fieldResExpsAndArgsUsed + let extraArgsUsedByFields = snd <$> fieldResExpsAndArgsUsed - resExp <- fieldCombineFun (ConE (constructorName conInfo)) fieldExps - return $ Clause (funPats ++ extraPats ++ [fieldPats]) (NormalB resExp) [] + (resExp, extraArgsUsedByResult) <- + fieldCombineFun + conIdx + (constructorVariant conInfo) + (constructorName conInfo) + extraPatExps + fieldResExps + let resUsedNames = allUsedNames resExp + let extraArgsUsed = + fmap or $ + List.transpose $ + extraArgsUsedByResult : extraArgsUsedByFields + let extraArgsPats = + zipWith + (\pat used -> if used then pat else WildP) + extraPats + extraArgsUsed + let transformPat (VarP nm) = + if S.member nm resUsedNames then VarP nm else WildP + transformPat p = p + return $ + Clause + ( fmap transformPat $ + concat (zipWith (:) funPats funLiftedPats) + ++ extraArgsPats + ++ [fieldPats] + ) + (NormalB resExp) + [] -- | Configuration for a unary operation type class generation on a GADT. data UnaryOpClassConfig = UnaryOpClassConfig - { unaryOpFieldConfig :: UnaryOpFieldConfig, + { unaryOpConfigs :: [UnaryOpConfig], unaryOpInstanceNames :: [Name], - unaryOpFunNames :: [Name] + unaryOpExtraVars :: DeriveConfig -> Q [(Type, Kind)], + unaryOpInstanceTypeFromConfig :: + DeriveConfig -> + [(Type, Kind)] -> + [(Type, Kind)] -> + Name -> + Q Type, + unaryOpAllowExistential :: Bool } +-- | Default unary operation instance type generator. +defaultUnaryOpInstanceTypeFromConfig :: + DeriveConfig -> [(Type, Kind)] -> [(Type, Kind)] -> Name -> Q Type +defaultUnaryOpInstanceTypeFromConfig _ _ _ = conT + +-- | Configuration for the derivation rules for a unary operation that can be +-- derived by transforming each field and then combining the results. +data UnaryOpFieldConfig = UnaryOpFieldConfig + { extraPatNames :: [String], + extraLiftedPatNames :: Int -> [String], + fieldResFun :: + ConstructorVariant -> + Name -> + [Exp] -> + Int -> + Exp -> + Exp -> + Q (Exp, [Bool]), + fieldCombineFun :: + Int -> + ConstructorVariant -> + Name -> + [Exp] -> + [Exp] -> + Q (Exp, [Bool]), + fieldFunExp :: FieldFunExp + } + +-- | Configuration for the derivation rules for a unary operation. +class UnaryOpFunConfig config where + genUnaryOpFun :: + -- | Derive configuration + DeriveConfig -> + -- | Configuration + config -> + -- | Function names + [Name] -> + -- | Number of functor arguments to the class + Int -> + -- | Extra variables + [(Type, Kind)] -> + -- | Kept variables + [(Type, Kind)] -> + -- | Argument variables + [(Type, Kind)] -> + -- | Whether the variable is used in fields + (Name -> Bool) -> + -- | Constructor infos + [ConstructorInfo] -> + Q Dec + +instance UnaryOpFunConfig UnaryOpFieldConfig where + genUnaryOpFun _ config funNames n _ _ argTypes _ constructors = do + clauses <- + zipWithM + ( genUnaryOpFieldClause + config + argTypes + ) + [0 ..] + constructors + let instanceFunName = funNames !! n + return $ FunD instanceFunName clauses + -- | Generate a unary operation type class instance for a GADT. genUnaryOpClass :: + DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec] -genUnaryOpClass (UnaryOpClassConfig {..}) n typName = do - CheckArgsResult {..} <- - checkArgs - (occName $ head unaryOpInstanceNames) - (length unaryOpInstanceNames - 1) - typName - n - let ctxForVar :: TyVarBndr_ flag -> Q (Maybe Pred) - ctxForVar var = case tvKind var of - StarT -> Just <$> [t|$(conT $ head unaryOpInstanceNames) $(varT $ tvName var)|] - AppT (AppT ArrowT StarT) StarT -> - Just <$> [t|$(conT $ unaryOpInstanceNames !! 1) $(varT $ tvName var)|] - AppT (AppT (AppT ArrowT StarT) StarT) StarT -> - Just <$> [t|$(conT $ unaryOpInstanceNames !! 2) $(varT $ tvName var)|] - AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) StarT -> - Just <$> [t|$(conT $ unaryOpInstanceNames !! 3) $(varT $ tvName var)|] - AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) _ -> - fail $ "Unsupported kind: " <> show (tvKind var) - _ -> return Nothing - ctxs <- traverse ctxForVar $ filter (isVarUsedInFields . tvName) keptNewVars - clauses <- +genUnaryOpClass deriveConfig (UnaryOpClassConfig {..}) n typName = do + result@CheckArgsResult {..} <- + specializeResult (evalModeSpecializeList deriveConfig) + =<< freshenCheckArgsResult True + =<< checkArgs + (nameBase $ head unaryOpInstanceNames) + (length unaryOpInstanceNames - 1) + typName + unaryOpAllowExistential + n + extraVars <- unaryOpExtraVars deriveConfig + instanceTypes <- traverse - (genUnaryOpClause unaryOpFunNames unaryOpFieldConfig argNewNames) + (unaryOpInstanceTypeFromConfig deriveConfig extraVars keptVars) + unaryOpInstanceNames + let isTypeUsedInFields (VarT nm) = isVarUsedInFields result nm + isTypeUsedInFields _ = False + ctxs <- + traverse (uncurry $ ctxForVar instanceTypes) $ + filter (isTypeUsedInFields . fst) keptVars + let keptType = foldl AppT (ConT typName) $ fmap fst keptVars + instanceFuns <- + traverse + ( \(UnaryOpConfig config funNames) -> + genUnaryOpFun + deriveConfig + config + funNames + n + extraVars + keptVars + argVars + (isVarUsedInFields result) + constructors + ) + unaryOpConfigs + let instanceName = unaryOpInstanceNames !! n + let instanceType = AppT (instanceTypes !! n) keptType + extraPreds <- + extraConstraint + deriveConfig + typName + instanceName + extraVars + keptVars constructors - let instanceType = - AppT (ConT $ unaryOpInstanceNames !! n) $ - foldl AppT (ConT typName) $ - fmap VarT keptNewNames - let instanceFunName = unaryOpFunNames !! n - let instanceFun = FunD instanceFunName clauses return [ InstanceD Nothing - (catMaybes ctxs) + (extraPreds ++ catMaybes ctxs) instanceType - [instanceFun] + instanceFuns ] diff --git a/src/Grisette/Internal/TH/GADT/UnifiedOpCommon.hs b/src/Grisette/Internal/TH/GADT/UnifiedOpCommon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/GADT/UnifiedOpCommon.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Internal.TH.GADT.UnifiedOpCommon +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.GADT.UnifiedOpCommon + ( UnaryOpUnifiedConfig (..), + defaultUnaryOpUnifiedFun, + ) +where + +import Grisette.Internal.TH.GADT.Common (DeriveConfig (evalModeConfig)) +import Grisette.Internal.TH.GADT.UnaryOpCommon + ( UnaryOpFunConfig (genUnaryOpFun), + ) +import Grisette.Internal.Unified.Util (withMode) +import Language.Haskell.TH + ( Exp (VarE), + Kind, + Name, + Q, + Type (AppT, ArrowT, StarT, VarT), + appE, + clause, + funD, + newName, + normalB, + varE, + varP, + ) + +-- | Default implementation for the derivation rules for a unified operation. +defaultUnaryOpUnifiedFun :: [Name] -> Type -> (Type, Kind) -> Q (Maybe Exp) +defaultUnaryOpUnifiedFun funNames modeTy (ty, kind) = + case kind of + StarT -> + Just + <$> [| + $(varE $ head funNames) @($(return modeTy)) + @($(return ty)) + |] + AppT (AppT ArrowT StarT) StarT -> + Just + <$> [| + $(varE $ funNames !! 1) @($(return modeTy)) + @($(return ty)) + |] + AppT (AppT (AppT ArrowT StarT) StarT) StarT -> + Just + <$> [| + $(varE $ funNames !! 2) @($(return modeTy)) + @($(return ty)) + |] + _ -> return Nothing + +-- | Configuration for the derivation rules for a unified operation. +newtype UnaryOpUnifiedConfig = UnaryOpUnifiedConfig + {unifiedFun :: Type -> (Type, Kind) -> Q (Maybe Exp)} + +instance UnaryOpFunConfig UnaryOpUnifiedConfig where + genUnaryOpFun + deriveConfig + (UnaryOpUnifiedConfig {..}) + funNames + n + extraVars + keptTypes + _ + isVarUsedInFields + _ = do + modeTy <- case evalModeConfig deriveConfig of + [] -> return $ fst $ head extraVars + [(i, _)] -> return $ fst $ keptTypes !! i + _ -> fail "Unified classes does not support multiple evaluation modes" + let isTypeUsedInFields (VarT nm) = isVarUsedInFields nm + isTypeUsedInFields _ = False + exprs <- + traverse (unifiedFun modeTy) $ + filter (isTypeUsedInFields . fst) keptTypes + rVar <- newName "r" + let rf = + foldl + ( \exp nextFun -> case nextFun of + Nothing -> exp + Just fun -> appE (return fun) exp + ) + (return $ VarE rVar) + exprs + let instanceFunName = funNames !! n + funD + instanceFunName + [ clause + [varP rVar] + ( normalB + [| + withMode @($(return modeTy)) $(rf) $(rf) + |] + ) + [] + ] diff --git a/src/Grisette/Internal/TH/Util.hs b/src/Grisette/Internal/TH/Util.hs --- a/src/Grisette/Internal/TH/Util.hs +++ b/src/Grisette/Internal/TH/Util.hs @@ -13,8 +13,7 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.TH.Util - ( occName, - constructorInfoToType, + ( constructorInfoToType, tvIsMode, tvIsNat, tvIsStar, @@ -32,25 +31,64 @@ kindNumParam, concatPreds, putHaddock, + allUsedNamesMaybe, + allUsedNames, + isNonUnitTupleString, + isNonUnitTuple, + integerE, + mangleName, + dataTypeHasExistential, ) where #if MIN_VERSION_template_haskell(2,18,0) -import Language.Haskell.TH.Syntax (addModFinalizer, putDoc, DocLoc(DeclDoc)) +import Language.Haskell.TH.Syntax + ( DocLoc (DeclDoc), + ModName (ModName), + Name (Name), + NameFlavour (NameG, NameQ, NameS), + addModFinalizer, + putDoc, + ) +#else +import Language.Haskell.TH.Syntax + ( ModName (ModName), + Name (Name), + NameFlavour (NameG, NameQ, NameS), + ) #endif import Control.Monad (when) +import Data.Char (isAlphaNum, ord) import qualified Data.Map as M +import qualified Data.Set as S import GHC.TypeNats (Nat) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) import Language.Haskell.TH ( Dec (ClassD), + Exp + ( AppE, + AppTypeE, + ConE, + CondE, + InfixE, + LamE, + ListE, + LitE, + ParensE, + SigE, + TupE, + UInfixE, + VarE + ), Info (ClassI), Kind, - Name, Pred, Q, Type (AppT, ArrowT, ConT, ForallT, StarT, VarT), + integerL, + litE, + nameBase, newName, pprint, reify, @@ -72,12 +110,7 @@ mapTVName, tvKind, ) -import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName)) --- | Get the unqualified name of a t'Name'. -occName :: Name -> String -occName (Name (OccName name) _) = name - -- | Convert a 'ConstructorInfo' to a 'Type' of the constructor. constructorInfoToType :: DatatypeInfo -> ConstructorInfo -> Q Type constructorInfoToType dataType info = do @@ -240,3 +273,65 @@ putHaddock :: Name -> String -> Q () putHaddock _ _ = return () #endif + +-- | Get the names used in an expression. +allUsedNamesMaybe :: Maybe Exp -> S.Set Name +allUsedNamesMaybe Nothing = S.empty +allUsedNamesMaybe (Just exp) = allUsedNames exp + +-- | Get the names used in an expression. +allUsedNames :: Exp -> S.Set Name +allUsedNames (VarE nm) = S.singleton nm +allUsedNames (ConE n) = S.singleton n +allUsedNames (LitE _) = S.empty +allUsedNames (AppE e1 e2) = allUsedNames e1 `S.union` allUsedNames e2 +allUsedNames (AppTypeE e1 _) = allUsedNames e1 +allUsedNames (InfixE l e r) = + allUsedNamesMaybe l `S.union` allUsedNames e `S.union` allUsedNamesMaybe r +allUsedNames (UInfixE l e r) = + allUsedNames l `S.union` allUsedNames e `S.union` allUsedNames r +allUsedNames (ParensE e) = allUsedNames e +allUsedNames (LamE _ e) = allUsedNames e +allUsedNames (TupE es) = mconcat $ allUsedNamesMaybe <$> es +allUsedNames (CondE e1 e2 e3) = + allUsedNames e1 `S.union` allUsedNames e2 `S.union` allUsedNames e3 +allUsedNames (ListE es) = mconcat $ allUsedNames <$> es +allUsedNames (SigE e _) = allUsedNames e +allUsedNames exp = error $ "allUsedNames: unsupported expression: " <> show exp + +-- | Check if a string is the data constructor name of a non-unit tuple. +isNonUnitTupleString :: String -> Bool +isNonUnitTupleString ('(' : ',' : _) = True +isNonUnitTupleString _ = False + +-- | Check if a name is the data constructor name of a non-unit tuple. +isNonUnitTuple :: Name -> Bool +isNonUnitTuple nm = + isNonUnitTupleString $ nameBase nm + +-- | Convert an integer to an 'Exp'. +integerE :: (Integral a) => a -> Q Exp +integerE = litE . integerL . fromIntegral + +-- | Mangle a name string to contain only alphanumeric characters and +-- underscores. +mangleName :: Name -> String +mangleName nm@(Name _ flavor) = + case flavor of + NameS -> mangleBaseName $ nameBase nm + NameQ mod -> mangleModName mod <> "_" <> mangleBaseName (nameBase nm) + NameG _ _ mod -> mangleModName mod <> "_" <> mangleBaseName (nameBase nm) + _ -> error $ "mangleName: unsupported name flavor: " <> show flavor + where + mangleModName (ModName m) = mangleBaseName m + mangleBaseName l = "Mangled" ++ go l + go [] = [] + go (c : cs) + | isAlphaNum c || c == '_' = c : go cs + | otherwise = "_" <> show (ord c) <> go cs + +-- | Check if a data type has existential variables in constructors. +dataTypeHasExistential :: Name -> Q Bool +dataTypeHasExistential typName = do + d <- reifyDatatype typName + return $ not $ all (null . constructorVars) $ datatypeCons d diff --git a/src/Grisette/Internal/Unified/BVBVConversion.hs b/src/Grisette/Internal/Unified/BVBVConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/BVBVConversion.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Unified.BVBVConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.BVBVConversion + ( UnifiedBVBVConversion, + AllUnifiedBVBVConversion, + ) +where + +import GHC.TypeNats (KnownNat, Nat, type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN)) + +class + ( bv0 ~ bvn0 n0, + bv1 ~ bvn1 n1, + UnifiedFromIntegral mode bv0 bv1 + ) => + UnifiedBVBVConversionImpl + (mode :: EvalModeTag) + bvn0 + bvn1 + (n0 :: Nat) + (n1 :: Nat) + bv0 + bv1 + | bvn0 n0 -> bv0, + bvn1 n1 -> bv1, + bv0 -> bvn0 n0, + bv1 -> bvn1 n1 + +#define QUOTE() ' + +#define CONINSTANCE(ty0, ty1) \ +instance \ + (KnownNat n0, 1 <= n0, KnownNat n1, 1 <= n1) => \ + UnifiedBVBVConversionImpl QUOTE()C ty0 ty1 n0 n1 (ty0 n0) (ty1 n1) + +#define SYMINSTANCE(ty0, ty1) \ +instance \ + (KnownNat n0, 1 <= n0, KnownNat n1, 1 <= n1) => \ + UnifiedBVBVConversionImpl QUOTE()S ty0 ty1 n0 n1 (ty0 n0) (ty1 n1) + +#if 1 +CONINSTANCE(WordN, WordN) +CONINSTANCE(WordN, IntN) +CONINSTANCE(IntN, WordN) +CONINSTANCE(IntN, IntN) +SYMINSTANCE(SymWordN, SymWordN) +SYMINSTANCE(SymWordN, SymIntN) +SYMINSTANCE(SymIntN, SymWordN) +SYMINSTANCE(SymIntN, SymIntN) +#endif + +-- | Unified constraints for conversion between bit-vectors. +class + ( UnifiedBVBVConversionImpl + mode + (GetWordN mode) + (GetWordN mode) + n0 + n1 + (GetWordN mode n0) + (GetWordN mode n1), + UnifiedBVBVConversionImpl + mode + (GetWordN mode) + (GetIntN mode) + n0 + n1 + (GetWordN mode n0) + (GetIntN mode n1), + UnifiedBVBVConversionImpl + mode + (GetIntN mode) + (GetWordN mode) + n0 + n1 + (GetIntN mode n0) + (GetWordN mode n1), + UnifiedBVBVConversionImpl + mode + (GetIntN mode) + (GetIntN mode) + n0 + n1 + (GetIntN mode n0) + (GetIntN mode n1) + ) => + UnifiedBVBVConversion (mode :: EvalModeTag) n0 n1 + +instance + ( UnifiedBVBVConversionImpl + mode + (GetWordN mode) + (GetWordN mode) + n0 + n1 + (GetWordN mode n0) + (GetWordN mode n1), + UnifiedBVBVConversionImpl + mode + (GetWordN mode) + (GetIntN mode) + n0 + n1 + (GetWordN mode n0) + (GetIntN mode n1), + UnifiedBVBVConversionImpl + mode + (GetIntN mode) + (GetWordN mode) + n0 + n1 + (GetIntN mode n0) + (GetWordN mode n1), + UnifiedBVBVConversionImpl + mode + (GetIntN mode) + (GetIntN mode) + n0 + n1 + (GetIntN mode n0) + (GetIntN mode n1) + ) => + UnifiedBVBVConversion (mode :: EvalModeTag) n0 n1 + +-- | Evaluation mode with unified conversion from bit-vectors to bit-vectors. +class + ( forall n0 n1. + (KnownNat n0, KnownNat n1, 1 <= n0, 1 <= n1) => + UnifiedBVBVConversion mode n0 n1 + ) => + AllUnifiedBVBVConversion mode + +instance + ( forall n0 n1. + (KnownNat n0, KnownNat n1, 1 <= n0, 1 <= n1) => + UnifiedBVBVConversion mode n0 n1 + ) => + AllUnifiedBVBVConversion mode diff --git a/src/Grisette/Internal/Unified/BVFPConversion.hs b/src/Grisette/Internal/Unified/BVFPConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/BVFPConversion.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.BVFPConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.BVFPConversion + ( UnifiedBVFPConversion, + SafeUnifiedBVFPConversion, + AllUnifiedBVFPConversion, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.BVFPConversion +import Grisette.Internal.Internal.Impl.Unified.BVFPConversion () diff --git a/src/Grisette/Internal/Unified/BaseConstraint.hs b/src/Grisette/Internal/Unified/BaseConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/BaseConstraint.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Module : Grisette.Internal.Unified.EvaluationMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.BaseConstraint + ( ConSymConversion, + ) +where + +import Grisette.Internal.Core.Data.Class.ToCon (ToCon) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym) + +-- | A type that is used as a constraint for all the types in Grisette that can +-- be converted between concrete and symbolic types. +type ConSymConversion conType symType t = + ( ToCon t conType, + ToSym conType t, + ToCon symType t, + ToSym t symType + ) diff --git a/src/Grisette/Internal/Unified/BaseMonad.hs b/src/Grisette/Internal/Unified/BaseMonad.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/BaseMonad.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | +-- Module : Grisette.Internal.Unified.BaseMonad +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.BaseMonad + ( BaseMonad, + ) +where + +import Control.Monad.Identity (Identity) +import Data.Kind (Type) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) + +-- | A type family that specifies the base monad for the evaluation mode. +-- +-- Resolves to 'Identity' for `C` mode, and 'Union' for `S` mode. +type family + BaseMonad (mode :: EvalModeTag) = + (r :: Type -> Type) | r -> mode + where + BaseMonad 'C = Identity + BaseMonad 'S = Union diff --git a/src/Grisette/Internal/Unified/Class/UnifiedFiniteBits.hs b/src/Grisette/Internal/Unified/Class/UnifiedFiniteBits.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedFiniteBits.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedFiniteBits +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedFiniteBits + ( UnifiedFiniteBits (..), + symTestBit, + symSetBitTo, + symFromBits, + symBitBlast, + symLsb, + symMsb, + symPopCount, + symCountLeadingZeros, + symCountTrailingZeros, + ) +where + +import Data.Bits + ( Bits (popCount, testBit), + FiniteBits (countLeadingZeros, countTrailingZeros), + ) +import Data.Type.Bool (If) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SymFiniteBits + ( FromBits, + SymFiniteBits, + setBitTo, + ) +import qualified Grisette.Internal.Core.Data.Class.SymFiniteBits as SymFiniteBits +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.Unified.Class.UnifiedITEOp + ( UnifiedITEOp (withBaseITEOp), + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S), IsConMode) +import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symTestBit`. +symTestBit :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a) => + a -> + Int -> + GetBool mode +symTestBit a i = + withMode @mode + (withBaseFiniteBits @mode @a (testBit a i)) + (withBaseFiniteBits @mode @a (SymFiniteBits.symTestBit a i)) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symSetBitTo`. +symSetBitTo :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a) => + a -> + Int -> + GetBool mode -> + a +symSetBitTo a i b = + withMode @mode + (withBaseFiniteBits @mode @a (setBitTo a i b)) + (withBaseFiniteBits @mode @a (SymFiniteBits.symSetBitTo a i b)) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symFromBits`. +symFromBits :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a) => + [GetBool mode] -> + a +symFromBits bits = + withMode @mode + (withBaseFiniteBits @mode @a (SymFiniteBits.fromBits bits)) + (withBaseFiniteBits @mode @a (SymFiniteBits.symFromBits bits)) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symBitBlast`. +symBitBlast :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a) => + a -> + [GetBool mode] +symBitBlast a = + withMode @mode + (withBaseFiniteBits @mode @a (SymFiniteBits.bitBlast a)) + (withBaseFiniteBits @mode @a (SymFiniteBits.symBitBlast a)) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symLsb`. +symLsb :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a) => + a -> + GetBool mode +symLsb a = + withMode @mode + (withBaseFiniteBits @mode @a (SymFiniteBits.lsb a)) + (withBaseFiniteBits @mode @a (SymFiniteBits.symLsb a)) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symMsb`. +symMsb :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a) => + a -> + GetBool mode +symMsb a = + withMode @mode + (withBaseFiniteBits @mode @a (SymFiniteBits.msb a)) + (withBaseFiniteBits @mode @a (SymFiniteBits.symMsb a)) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symPopCount`. +symPopCount :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) => + a -> + a +symPopCount a = + withMode @mode + (withBaseFiniteBits @mode @a (fromIntegral $ popCount a)) + ( withBaseFiniteBits @mode @a $ + withBaseITEOp @mode @a (SymFiniteBits.symPopCount a) + ) + +-- | Unified +-- `Grisette.Internal.Core.Data.Class.SymFiniteBits.symCountLeadingZeros`. +symCountLeadingZeros :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) => + a -> + a +symCountLeadingZeros a = + withMode @mode + (withBaseFiniteBits @mode @a (fromIntegral $ countLeadingZeros a)) + ( withBaseFiniteBits @mode @a $ + withBaseITEOp @mode @a (SymFiniteBits.symCountLeadingZeros a) + ) + +-- | Unified +-- `Grisette.Internal.Core.Data.Class.SymFiniteBits.symCountTrailingZeros`. +symCountTrailingZeros :: + forall mode a. + (DecideEvalMode mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) => + a -> + a +symCountTrailingZeros a = + withMode @mode + (withBaseFiniteBits @mode @a (fromIntegral $ countTrailingZeros a)) + ( withBaseFiniteBits @mode @a $ + withBaseITEOp @mode @a (SymFiniteBits.symCountTrailingZeros a) + ) + +-- | A class that provides unified equality comparison. +-- +-- We use this type class to help resolve the constraints for `FiniteBits`, +-- `FromBits` and `SymFiniteBits`. +class UnifiedFiniteBits mode a where + withBaseFiniteBits :: + ((If (IsConMode mode) (FiniteBits a, FromBits a) (SymFiniteBits a)) => r) -> + r + +instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'C (WordN n) where + withBaseFiniteBits r = r + +instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'C (IntN n) where + withBaseFiniteBits r = r + +instance UnifiedFiniteBits 'C SomeWordN where + withBaseFiniteBits r = r + +instance UnifiedFiniteBits 'C SomeIntN where + withBaseFiniteBits r = r + +instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'S (SymWordN n) where + withBaseFiniteBits r = r + +instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'S (SymIntN n) where + withBaseFiniteBits r = r + +instance UnifiedFiniteBits 'S SomeSymWordN where + withBaseFiniteBits r = r + +instance UnifiedFiniteBits 'S SomeSymIntN where + withBaseFiniteBits r = r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedFromIntegral.hs b/src/Grisette/Internal/Unified/Class/UnifiedFromIntegral.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedFromIntegral.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedFromIntegral +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedFromIntegral + ( UnifiedFromIntegral (..), + symFromIntegral, + ) +where + +import Data.Type.Bool (If) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SymFromIntegral (SymFromIntegral) +import qualified Grisette.Internal.Core.Data.Class.SymFromIntegral as SymFromIntegral +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, ValidFP) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S), IsConMode) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymFromIntegral.symFromIntegral` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > symFromIntegral @mode a +symFromIntegral :: + forall mode a b. (DecideEvalMode mode, UnifiedFromIntegral mode a b) => a -> b +symFromIntegral a = + withMode @mode + (withBaseFromIntegral @mode @a @b $ fromIntegral a) + (withBaseFromIntegral @mode @a @b $ SymFromIntegral.symFromIntegral a) + +-- | A class that provides unified conversion from integral types. +-- +-- We use this type class to help resolve the constraints for `SymFromIntegral`. +class UnifiedFromIntegral (mode :: EvalModeTag) a b where + withBaseFromIntegral :: + ((If (IsConMode mode) (Integral a, Num b) (SymFromIntegral a b)) => r) -> r + +instance + {-# INCOHERENT #-} + ( DecideEvalMode mode, + (If (IsConMode mode) (Integral a, Num b) (SymFromIntegral a b)) + ) => + UnifiedFromIntegral mode a b + where + withBaseFromIntegral r = r + +instance UnifiedFromIntegral 'C Integer AlgReal where + withBaseFromIntegral r = r + +instance UnifiedFromIntegral 'C Integer Integer where + withBaseFromIntegral r = r + +instance (KnownNat n, 1 <= n) => UnifiedFromIntegral 'C Integer (IntN n) where + withBaseFromIntegral r = r + +instance + (KnownNat n, 1 <= n) => + UnifiedFromIntegral 'C Integer (WordN n) + where + withBaseFromIntegral r = r + +instance (ValidFP eb sb) => UnifiedFromIntegral 'C Integer (FP eb sb) where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'C (IntN n') AlgReal + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'C (IntN n') Integer + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'C (IntN n') (IntN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'C (IntN n') (WordN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', ValidFP eb sb) => + UnifiedFromIntegral 'C (IntN n') (FP eb sb) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'C (WordN n') AlgReal + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'C (WordN n') Integer + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'C (WordN n') (IntN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'C (WordN n') (WordN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', ValidFP eb sb) => + UnifiedFromIntegral 'C (WordN n') (FP eb sb) + where + withBaseFromIntegral r = r + +instance UnifiedFromIntegral 'S SymInteger SymAlgReal where + withBaseFromIntegral r = r + +instance UnifiedFromIntegral 'S SymInteger SymInteger where + withBaseFromIntegral r = r + +instance (KnownNat n, 1 <= n) => UnifiedFromIntegral 'S SymInteger (SymIntN n) where + withBaseFromIntegral r = r + +instance + (KnownNat n, 1 <= n) => + UnifiedFromIntegral 'S SymInteger (SymWordN n) + where + withBaseFromIntegral r = r + +instance (ValidFP eb sb) => UnifiedFromIntegral 'S SymInteger (SymFP eb sb) where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'S (SymIntN n') SymAlgReal + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'S (SymIntN n') SymInteger + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'S (SymIntN n') (SymIntN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'S (SymIntN n') (SymWordN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', ValidFP eb sb) => + UnifiedFromIntegral 'S (SymIntN n') (SymFP eb sb) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'S (SymWordN n') SymAlgReal + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n') => + UnifiedFromIntegral 'S (SymWordN n') SymInteger + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'S (SymWordN n') (SymIntN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => + UnifiedFromIntegral 'S (SymWordN n') (SymWordN n) + where + withBaseFromIntegral r = r + +instance + (KnownNat n', 1 <= n', ValidFP eb sb) => + UnifiedFromIntegral 'S (SymWordN n') (SymFP eb sb) + where + withBaseFromIntegral r = r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedITEOp.hs b/src/Grisette/Internal/Unified/Class/UnifiedITEOp.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedITEOp.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedITEOp +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedITEOp + ( symIte, + symIteMerge, + UnifiedITEOp (..), + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp +import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp diff --git a/src/Grisette/Internal/Unified/Class/UnifiedRep.hs b/src/Grisette/Internal/Unified/Class/UnifiedRep.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedRep.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedRep +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (..), + UnifiedSymRep (..), + ) +where + +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, ValidFP) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) + +-- | A class that gives the concrete type of a unified primitive type. +class UnifiedConRep a where + type ConType a + +-- | A class that gives the symbolic type of a unified primitive type. +class UnifiedSymRep a where + type SymType a + +instance UnifiedConRep Bool where + type ConType Bool = Bool + +instance UnifiedSymRep Bool where + type SymType Bool = SymBool + +instance UnifiedConRep SymBool where + type ConType SymBool = Bool + +instance UnifiedSymRep SymBool where + type SymType SymBool = SymBool + +instance UnifiedConRep Integer where + type ConType Integer = Integer + +instance UnifiedSymRep Integer where + type SymType Integer = SymInteger + +instance UnifiedConRep SymInteger where + type ConType SymInteger = Integer + +instance UnifiedSymRep SymInteger where + type SymType SymInteger = SymInteger + +instance UnifiedConRep AlgReal where + type ConType AlgReal = AlgReal + +instance UnifiedSymRep AlgReal where + type SymType AlgReal = SymAlgReal + +instance UnifiedConRep SymAlgReal where + type ConType SymAlgReal = AlgReal + +instance UnifiedSymRep SymAlgReal where + type SymType SymAlgReal = SymAlgReal + +instance (KnownNat n, 1 <= n) => UnifiedConRep (IntN n) where + type ConType (IntN n) = IntN n + +instance (KnownNat n, 1 <= n) => UnifiedSymRep (IntN n) where + type SymType (IntN n) = SymIntN n + +instance (KnownNat n, 1 <= n) => UnifiedConRep (SymIntN n) where + type ConType (SymIntN n) = IntN n + +instance (KnownNat n, 1 <= n) => UnifiedSymRep (SymIntN n) where + type SymType (SymIntN n) = SymIntN n + +instance (KnownNat n, 1 <= n) => UnifiedConRep (WordN n) where + type ConType (WordN n) = WordN n + +instance (KnownNat n, 1 <= n) => UnifiedSymRep (WordN n) where + type SymType (WordN n) = SymWordN n + +instance (KnownNat n, 1 <= n) => UnifiedConRep (SymWordN n) where + type ConType (SymWordN n) = WordN n + +instance (KnownNat n, 1 <= n) => UnifiedSymRep (SymWordN n) where + type SymType (SymWordN n) = SymWordN n + +instance (ValidFP eb sb) => UnifiedConRep (FP eb sb) where + type ConType (FP eb sb) = FP eb sb + +instance (ValidFP eb sb) => UnifiedSymRep (FP eb sb) where + type SymType (FP eb sb) = SymFP eb sb + +instance (ValidFP eb sb) => UnifiedConRep (SymFP eb sb) where + type ConType (SymFP eb sb) = FP eb sb + +instance (ValidFP eb sb) => UnifiedSymRep (SymFP eb sb) where + type SymType (SymFP eb sb) = SymFP eb sb diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeBitCast.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeBitCast.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeBitCast.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeBitCast +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeBitCast + ( safeBitCast, + UnifiedSafeBitCast (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (+), type (<=)) +import Grisette.Internal.Core.Data.Class.SafeBitCast (SafeBitCast) +import qualified Grisette.Internal.Core.Data.Class.SafeBitCast +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, NotRepresentableFPError, ValidFP) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSub @mode a b +safeBitCast :: + forall mode e a b m. + ( MonadError e m, + UnifiedSafeBitCast mode e a b m + ) => + a -> + m b +safeBitCast a = + withBaseSafeBitCast @mode @e @a @b @m $ + Grisette.Internal.Core.Data.Class.SafeBitCast.safeBitCast a +{-# INLINE safeBitCast #-} + +-- | A class that provides unified safe bitcast operations. +-- +-- We use this type class to help resolve the constraints for `SafeBitCast`. +class UnifiedSafeBitCast (mode :: EvalModeTag) e a b m where + withBaseSafeBitCast :: ((SafeBitCast e a b m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeBitCast e a b m) => + UnifiedSafeBitCast mode e a b m + where + withBaseSafeBitCast r = r + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching mode m, + ValidFP eb sb, + KnownNat n, + 1 <= n, + n ~ (eb + sb) + ) => + UnifiedSafeBitCast mode NotRepresentableFPError (FP eb sb) (WordN n) m + where + withBaseSafeBitCast r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching mode m, + ValidFP eb sb, + KnownNat n, + 1 <= n, + n ~ (eb + sb) + ) => + UnifiedSafeBitCast mode NotRepresentableFPError (FP eb sb) (IntN n) m + where + withBaseSafeBitCast r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching 'S m, + ValidFP eb sb, + KnownNat n, + 1 <= n, + n ~ (eb + sb) + ) => + UnifiedSafeBitCast 'S NotRepresentableFPError (SymFP eb sb) (SymWordN n) m + where + withBaseSafeBitCast r = withBaseBranching @'S @m r + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching 'S m, + ValidFP eb sb, + KnownNat n, + 1 <= n, + n ~ (eb + sb) + ) => + UnifiedSafeBitCast 'S NotRepresentableFPError (SymFP eb sb) (SymIntN n) m + where + withBaseSafeBitCast r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeDiv.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeDiv.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeDiv.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeDiv +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeDiv + ( safeDiv, + safeMod, + safeDivMod, + safeQuot, + safeRem, + safeQuotRem, + UnifiedSafeDiv (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeDiv + ( ArithException, + SafeDiv, + ) +import qualified Grisette.Internal.Core.Data.Class.SafeDiv +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBVException, + SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag + ( EvalModeTag (S), + ) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeDiv` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeDiv @mode a b +safeDiv :: + forall mode e a m. + (MonadError e m, UnifiedSafeDiv mode e a m) => + a -> + a -> + m a +safeDiv a b = + withBaseSafeDiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDiv.safeDiv a b +{-# INLINE safeDiv #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeMod` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeMod @mode a b +safeMod :: + forall mode e a m. + (MonadError e m, UnifiedSafeDiv mode e a m) => + a -> + a -> + m a +safeMod a b = + withBaseSafeDiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDiv.safeMod a b +{-# INLINE safeMod #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeDivMod` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeDivMod @mode a b +safeDivMod :: + forall mode e a m. + (MonadError e m, UnifiedSafeDiv mode e a m) => + a -> + a -> + m (a, a) +safeDivMod a b = + withBaseSafeDiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDiv.safeDivMod a b +{-# INLINE safeDivMod #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeQuot` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeQuot @mode a b +safeQuot :: + forall mode e a m. + (MonadError e m, UnifiedSafeDiv mode e a m) => + a -> + a -> + m a +safeQuot a b = + withBaseSafeDiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDiv.safeQuot a b +{-# INLINE safeQuot #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeRem` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeRem @mode a b +safeRem :: + forall mode e a m. + (MonadError e m, UnifiedSafeDiv mode e a m) => + a -> + a -> + m a +safeRem a b = + withBaseSafeDiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDiv.safeRem a b +{-# INLINE safeRem #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeQuotRem` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeQuotRem @mode a b +safeQuotRem :: + forall mode e a m. + (MonadError e m, UnifiedSafeDiv mode e a m) => + a -> + a -> + m (a, a) +safeQuotRem a b = + withBaseSafeDiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDiv.safeQuotRem a b +{-# INLINE safeQuotRem #-} + +-- | A class that provides unified division operations. +-- +-- We use this type class to help resolve the constraints for `SafeDiv`. +class UnifiedSafeDiv (mode :: EvalModeTag) e a m where + withBaseSafeDiv :: ((SafeDiv e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeDiv e a m) => + UnifiedSafeDiv mode e a m + where + withBaseSafeDiv r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m) => + UnifiedSafeDiv mode ArithException Integer m + where + withBaseSafeDiv r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m) => + UnifiedSafeDiv 'S ArithException SymInteger m + where + withBaseSafeDiv r = withBaseBranching @'S @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeDiv mode ArithException (IntN n) m + where + withBaseSafeDiv r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeDiv 'S ArithException (SymIntN n) m + where + withBaseSafeDiv r = withBaseBranching @'S @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeDiv mode ArithException (WordN n) m + where + withBaseSafeDiv r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeDiv 'S ArithException (SymWordN n) m + where + withBaseSafeDiv r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeDiv + mode + (Either SomeBVException ArithException) + SomeIntN + m + where + withBaseSafeDiv r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeDiv + 'S + (Either SomeBVException ArithException) + SomeSymIntN + m + where + withBaseSafeDiv r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeDiv + mode + (Either SomeBVException ArithException) + SomeWordN + m + where + withBaseSafeDiv r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeDiv + 'S + (Either SomeBVException ArithException) + SomeSymWordN + m + where + withBaseSafeDiv r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeFdiv.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeFdiv.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeFdiv.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeFdiv +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeFdiv + ( safeFdiv, + UnifiedSafeFdiv (..), + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Error.Class (MonadError) +import Grisette.Internal.Core.Data.Class.SafeFdiv (SafeFdiv) +import qualified Grisette.Internal.Core.Data.Class.SafeFdiv +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeFdiv @mode a b +safeFdiv :: + forall mode e a m. + (MonadError e m, UnifiedSafeFdiv mode e a m) => + a -> + a -> + m a +safeFdiv a b = + withBaseUnifiedSafeFdiv @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv a b +{-# INLINE safeFdiv #-} + +-- | A class that provides unified floating division operations. +-- +-- We use this type class to help resolve the constraints for `SafeFdiv`. +class UnifiedSafeFdiv (mode :: EvalModeTag) e a m where + withBaseUnifiedSafeFdiv :: ((SafeFdiv e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeFdiv e a m) => + UnifiedSafeFdiv mode e a m + where + withBaseUnifiedSafeFdiv r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m) => + UnifiedSafeFdiv mode ArithException AlgReal m + where + withBaseUnifiedSafeFdiv r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m) => + UnifiedSafeFdiv 'S ArithException SymAlgReal m + where + withBaseUnifiedSafeFdiv r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeFromFP.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeFromFP.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeFromFP.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeFromFP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeFromFP + ( UnifiedSafeFromFP (..), + safeFromFP, + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeFromFP (SafeFromFP) +import qualified Grisette.Internal.Core.Data.Class.SafeFromFP as SafeFromFP +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeFromFP.safeFromFP` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeFromFP @mode mode fp +safeFromFP :: + forall mode e a fp fprd m. + (UnifiedSafeFromFP mode e a fp fprd m, MonadError e m) => + fprd -> + fp -> + m a +safeFromFP rd fp = + withBaseSafeFromFP @mode @e @a @fp @fprd @m $ + SafeFromFP.safeFromFP rd fp + +-- | A class that provides unified safe conversion from floating points. +-- +-- We use this type class to help resolve the constraints for `SafeFromFP`. +class UnifiedSafeFromFP (mode :: EvalModeTag) e a fp fprd m where + withBaseSafeFromFP :: ((SafeFromFP e a fp fprd m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeFromFP e a fp fprd m) => + UnifiedSafeFromFP mode e a fp fprd m + where + withBaseSafeFromFP r = r + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching mode m, + ValidFP eb sb + ) => + UnifiedSafeFromFP + mode + NotRepresentableFPError + Integer + (FP eb sb) + FPRoundingMode + m + where + withBaseSafeFromFP r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching mode m, + ValidFP eb sb + ) => + UnifiedSafeFromFP + mode + NotRepresentableFPError + AlgReal + (FP eb sb) + FPRoundingMode + m + where + withBaseSafeFromFP r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching mode m, + ValidFP eb sb, + KnownNat n, + 1 <= n + ) => + UnifiedSafeFromFP + mode + NotRepresentableFPError + (IntN n) + (FP eb sb) + FPRoundingMode + m + where + withBaseSafeFromFP r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching mode m, + ValidFP eb sb, + KnownNat n, + 1 <= n + ) => + UnifiedSafeFromFP + mode + NotRepresentableFPError + (WordN n) + (FP eb sb) + FPRoundingMode + m + where + withBaseSafeFromFP r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching 'S m, + ValidFP eb sb + ) => + UnifiedSafeFromFP + 'S + NotRepresentableFPError + SymInteger + (SymFP eb sb) + SymFPRoundingMode + m + where + withBaseSafeFromFP r = withBaseBranching @'S @m r + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching 'S m, + ValidFP eb sb + ) => + UnifiedSafeFromFP + 'S + NotRepresentableFPError + SymAlgReal + (SymFP eb sb) + SymFPRoundingMode + m + where + withBaseSafeFromFP r = withBaseBranching @'S @m r + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching 'S m, + ValidFP eb sb, + KnownNat n, + 1 <= n + ) => + UnifiedSafeFromFP + 'S + NotRepresentableFPError + (SymIntN n) + (SymFP eb sb) + SymFPRoundingMode + m + where + withBaseSafeFromFP r = withBaseBranching @'S @m r + +instance + ( MonadError NotRepresentableFPError m, + UnifiedBranching 'S m, + ValidFP eb sb, + KnownNat n, + 1 <= n + ) => + UnifiedSafeFromFP + 'S + NotRepresentableFPError + (SymWordN n) + (SymFP eb sb) + SymFPRoundingMode + m + where + withBaseSafeFromFP r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeLinearArith.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeLinearArith.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeLinearArith.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeLinearArith +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeLinearArith + ( safeAdd, + safeNeg, + safeSub, + UnifiedSafeLinearArith (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeLinearArith + ( ArithException, + SafeLinearArith, + ) +import qualified Grisette.Internal.Core.Data.Class.SafeLinearArith +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBVException, + SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag + ( EvalModeTag (S), + ) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeAdd` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeAdd @mode a b +safeAdd :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeLinearArith mode e a m + ) => + a -> + a -> + m a +safeAdd a b = + withBaseSafeLinearArith @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeLinearArith.safeAdd a b +{-# INLINE safeAdd #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeNeg` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeNeg @mode a +safeNeg :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeLinearArith mode e a m + ) => + a -> + m a +safeNeg a = + withBaseSafeLinearArith @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeLinearArith.safeNeg a +{-# INLINE safeNeg #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSub @mode a b +safeSub :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeLinearArith mode e a m + ) => + a -> + a -> + m a +safeSub a b = + withBaseSafeLinearArith @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub a b +{-# INLINE safeSub #-} + +-- | A class that provides unified linear arithmetic operations. +-- +-- We use this type class to help resolve the constraints for `SafeLinearArith`. +class UnifiedSafeLinearArith (mode :: EvalModeTag) e a m where + withBaseSafeLinearArith :: ((SafeLinearArith e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeLinearArith e a m) => + UnifiedSafeLinearArith mode e a m + where + withBaseSafeLinearArith r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m) => + UnifiedSafeLinearArith mode ArithException Integer m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m) => + UnifiedSafeLinearArith 'S ArithException SymInteger m + where + withBaseSafeLinearArith r = withBaseBranching @'S @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith mode ArithException (IntN n) m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith 'S ArithException (SymIntN n) m + where + withBaseSafeLinearArith r = withBaseBranching @'S @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith mode ArithException (WordN n) m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith 'S ArithException (SymWordN n) m + where + withBaseSafeLinearArith r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeLinearArith + mode + (Either SomeBVException ArithException) + SomeIntN + m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeLinearArith + 'S + (Either SomeBVException ArithException) + SomeSymIntN + m + where + withBaseSafeLinearArith r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeLinearArith + mode + (Either SomeBVException ArithException) + SomeWordN + m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeLinearArith + 'S + (Either SomeBVException ArithException) + SomeSymWordN + m + where + withBaseSafeLinearArith r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeSymRotate.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeSymRotate.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeSymRotate.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeSymRotate +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeSymRotate + ( safeSymRotateL, + safeSymRotateR, + UnifiedSafeSymRotate (..), + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate) +import qualified Grisette.Internal.Core.Data.Class.SafeSymRotate +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBVException, + SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag + ( EvalModeTag (S), + ) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateL` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymRotateL @mode a b +safeSymRotateL :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymRotate mode e a m + ) => + a -> + a -> + m a +safeSymRotateL a b = + withBaseSafeSymRotate @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateL a b +{-# INLINE safeSymRotateL #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateR` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymRotateR @mode a b +safeSymRotateR :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymRotate mode e a m + ) => + a -> + a -> + m a +safeSymRotateR a b = + withBaseSafeSymRotate @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateR a b +{-# INLINE safeSymRotateR #-} + +-- | A class that provides unified safe symbolic rotation operations. +-- +-- We use this type class to help resolve the constraints for `SafeSymRotate`. +class UnifiedSafeSymRotate (mode :: EvalModeTag) e a m where + withBaseSafeSymRotate :: ((SafeSymRotate e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeSymRotate e a m) => + UnifiedSafeSymRotate mode e a m + where + withBaseSafeSymRotate r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate mode ArithException (IntN n) m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate 'S ArithException (SymIntN n) m + where + withBaseSafeSymRotate r = withBaseBranching @'S @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate mode ArithException (WordN n) m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate 'S ArithException (SymWordN n) m + where + withBaseSafeSymRotate r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymRotate + mode + (Either SomeBVException ArithException) + SomeIntN + m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeSymRotate + 'S + (Either SomeBVException ArithException) + SomeSymIntN + m + where + withBaseSafeSymRotate r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymRotate + mode + (Either SomeBVException ArithException) + SomeWordN + m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeSymRotate + 'S + (Either SomeBVException ArithException) + SomeSymWordN + m + where + withBaseSafeSymRotate r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSafeSymShift.hs b/src/Grisette/Internal/Unified/Class/UnifiedSafeSymShift.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSafeSymShift.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSafeSymShift +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSafeSymShift + ( safeSymShiftL, + safeSymShiftR, + safeSymStrictShiftL, + safeSymStrictShiftR, + UnifiedSafeSymShift (..), + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeSymShift (SafeSymShift) +import qualified Grisette.Internal.Core.Data.Class.SafeSymShift +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBVException, + SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Internal.Unified.EvalModeTag + ( EvalModeTag (S), + ) +import Grisette.Internal.Unified.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftL` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymShiftL @mode a b +safeSymShiftL :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymShiftL a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftL a b +{-# INLINE safeSymShiftL #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftR` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymShiftR @mode a b +safeSymShiftR :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymShiftR a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftR a b +{-# INLINE safeSymShiftR #-} + +-- | Unified +-- `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftL` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymStrictShiftL @mode a b +safeSymStrictShiftL :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymStrictShiftL a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftL a b +{-# INLINE safeSymStrictShiftL #-} + +-- | Unified +-- `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftR` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymStrictShiftR @mode a b +safeSymStrictShiftR :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymStrictShiftR a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftR a b +{-# INLINE safeSymStrictShiftR #-} + +-- | A class that provides unified safe symbolic rotation operations. +-- +-- We use this type class to help resolve the constraints for `SafeSymShift`. +class UnifiedSafeSymShift (mode :: EvalModeTag) e a m where + withBaseSafeSymShift :: ((SafeSymShift e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeSymShift e a m) => + UnifiedSafeSymShift mode e a m + where + withBaseSafeSymShift r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift mode ArithException (IntN n) m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift 'S ArithException (SymIntN n) m + where + withBaseSafeSymShift r = withBaseBranching @'S @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift mode ArithException (WordN n) m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift 'S ArithException (SymWordN n) m + where + withBaseSafeSymShift r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymShift + mode + (Either SomeBVException ArithException) + SomeIntN + m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeSymShift + 'S + (Either SomeBVException ArithException) + SomeSymIntN + m + where + withBaseSafeSymShift r = withBaseBranching @'S @m r + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymShift + mode + (Either SomeBVException ArithException) + SomeWordN + m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either SomeBVException ArithException) m, + UnifiedBranching 'S m + ) => + UnifiedSafeSymShift + 'S + (Either SomeBVException ArithException) + SomeSymWordN + m + where + withBaseSafeSymShift r = withBaseBranching @'S @m r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSimpleMergeable.hs b/src/Grisette/Internal/Unified/Class/UnifiedSimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSimpleMergeable.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSimpleMergeable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (..), + UnifiedSimpleMergeable (..), + UnifiedSimpleMergeable1 (..), + UnifiedSimpleMergeable2 (..), + mrgIf, + liftBaseMonad, + mrgIte, + mrgIte1, + liftMrgIte, + mrgIte2, + liftMrgIte2, + simpleMerge, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable +import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSolvable.hs b/src/Grisette/Internal/Unified/Class/UnifiedSolvable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSolvable.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSolvable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSolvable + ( UnifiedSolvable (withBaseSolvable), + con, + pattern Con, + conView, + ) +where + +import Data.Type.Bool (If) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable) +import qualified Grisette.Internal.Core.Data.Class.Solvable as Grisette +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, ValidFP) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S), IsConMode) +import Grisette.Internal.Unified.Util (DecideEvalMode, withMode) + +-- $setup +-- >>> import Grisette.Core (ssym) + +-- | Wrap a concrete value in a symbolic value. +-- +-- >>> con True :: Bool +-- True +-- +-- >>> con True :: SymBool +-- true +con :: + forall mode a con. (DecideEvalMode mode, UnifiedSolvable mode a con) => con -> a +con v = + withMode @mode + (withBaseSolvable @mode @a @con v) + (withBaseSolvable @mode @a @con $ Grisette.con v) + +-- | Extract the concrete value from a symbolic value. +-- +-- >>> conView (con True :: SymBool) +-- Just True +-- +-- >>> conView (ssym "a" :: SymBool) +-- Nothing +-- +-- >>> conView True +-- Just True +conView :: + forall mode a con. + (DecideEvalMode mode, UnifiedSolvable mode a con) => + a -> + Maybe con +conView v = + withMode @mode + (withBaseSolvable @mode @a @con $ Just v) + (withBaseSolvable @mode @a @con $ Grisette.conView v) + +-- | A pattern synonym for extracting the concrete value from a symbolic value. +-- +-- >>> case con True :: SymBool of Con v -> v +-- True +-- +-- >>> case ssym "a" :: SymBool of Con v -> Just v; _ -> Nothing +-- Nothing +pattern Con :: (DecideEvalMode mode, UnifiedSolvable mode a con) => con -> a +pattern Con v <- + (conView -> Just v) + where + Con v = con v + +-- | A class that provides the ability to extract/wrap the concrete value +-- from/into a symbolic value. +class UnifiedSolvable mode a con | a -> mode con, con mode -> a where + withBaseSolvable :: + ((If (IsConMode mode) (a ~ con) (Solvable con a)) => r) -> r + +instance UnifiedSolvable 'C Bool Bool where + withBaseSolvable r = r + +instance UnifiedSolvable 'S SymBool Bool where + withBaseSolvable r = r + +instance UnifiedSolvable 'C Integer Integer where + withBaseSolvable r = r + +instance UnifiedSolvable 'S SymInteger Integer where + withBaseSolvable r = r + +instance UnifiedSolvable 'C AlgReal AlgReal where + withBaseSolvable r = r + +instance UnifiedSolvable 'S SymAlgReal AlgReal where + withBaseSolvable r = r + +instance (KnownNat n, 1 <= n) => UnifiedSolvable 'C (WordN n) (WordN n) where + withBaseSolvable r = r + +instance (KnownNat n, 1 <= n) => UnifiedSolvable 'S (SymWordN n) (WordN n) where + withBaseSolvable r = r + +instance (KnownNat n, 1 <= n) => UnifiedSolvable 'C (IntN n) (IntN n) where + withBaseSolvable r = r + +instance (KnownNat n, 1 <= n) => UnifiedSolvable 'S (SymIntN n) (IntN n) where + withBaseSolvable r = r + +instance (ValidFP eb sb) => UnifiedSolvable 'C (FP eb sb) (FP eb sb) where + withBaseSolvable r = r + +instance (ValidFP eb sb) => UnifiedSolvable 'S (SymFP eb sb) (FP eb sb) where + withBaseSolvable r = r diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSymEq.hs b/src/Grisette/Internal/Unified/Class/UnifiedSymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSymEq.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSymEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSymEq + ( UnifiedSymEq (..), + UnifiedSymEq1 (..), + UnifiedSymEq2 (..), + (.==), + (./=), + symDistinct, + liftSymEq, + symEq1, + liftSymEq2, + symEq2, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq +import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq diff --git a/src/Grisette/Internal/Unified/Class/UnifiedSymOrd.hs b/src/Grisette/Internal/Unified/Class/UnifiedSymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Class/UnifiedSymOrd.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.Class.UnifiedSymOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Class.UnifiedSymOrd + ( UnifiedSymOrd (..), + UnifiedSymOrd1 (..), + UnifiedSymOrd2 (..), + (.<=), + (.<), + (.>=), + (.>), + symCompare, + liftSymCompare, + symCompare1, + liftSymCompare2, + symCompare2, + symMax, + symMin, + mrgMax, + mrgMin, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd +import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd diff --git a/src/Grisette/Internal/Unified/EvalMode.hs b/src/Grisette/Internal/Unified/EvalMode.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/EvalMode.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.EvalMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.EvalMode + ( EvalModeBase, + EvalModeInteger, + EvalModeBV, + EvalModeFP, + EvalModeAlgReal, + EvalModeAll, + MonadEvalModeAll, + genEvalMode, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.EvalMode +import Grisette.Internal.Internal.Impl.Unified.EvalMode () diff --git a/src/Grisette/Internal/Unified/EvalModeTag.hs b/src/Grisette/Internal/Unified/EvalModeTag.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/EvalModeTag.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | +-- Module : Grisette.Internal.Unified.EvalModeTag +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.EvalModeTag + ( EvalModeTag (..), + IsConMode, + ) +where + +import Language.Haskell.TH.Syntax (Lift) + +-- | Evaluation mode for unified types. 'C' means concrete evaluation, 'S' +-- means symbolic evaluation. +data EvalModeTag = C | S deriving (Lift, Show, Eq) + +-- | Type family to check if a mode is 'C'. +type family IsConMode (mode :: EvalModeTag) = (r :: Bool) | r -> mode where + IsConMode 'C = 'True + IsConMode 'S = 'False diff --git a/src/Grisette/Internal/Unified/FPFPConversion.hs b/src/Grisette/Internal/Unified/FPFPConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/FPFPConversion.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.FPFPConversion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.FPFPConversion + ( UnifiedFPFPConversion, + AllUnifiedFPFPConversion, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.FPFPConversion +import Grisette.Internal.Internal.Impl.Unified.FPFPConversion () diff --git a/src/Grisette/Internal/Unified/Theories.hs b/src/Grisette/Internal/Unified/Theories.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Theories.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Grisette.Internal.Unified.Theories +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Theories (TheoryToUnify (..), isUFun) where + +-- | This data type is used to represent the theories that is unified. +-- +-- The 'UFun' constructor is used to represent a specific uninterpreted function +-- type. The type is uncurried. +data TheoryToUnify + = UBool + | UIntN + | UWordN + | UInteger + | UAlgReal + | UFP + | UFun [TheoryToUnify] + deriving (Eq, Show) + +-- | Check if the theory is a uninterpreted function. +isUFun :: TheoryToUnify -> Bool +isUFun (UFun _) = True +isUFun _ = False diff --git a/src/Grisette/Internal/Unified/UnifiedAlgReal.hs b/src/Grisette/Internal/Unified/UnifiedAlgReal.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedAlgReal.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedAlgReal +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedAlgReal + ( UnifiedAlgReal, + GetAlgReal, + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Error.Class (MonadError) +import Grisette.Internal.Core.Data.Class.SafeFdiv (FdivOr) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymPrim (Prim) +import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) +import Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (ConType), + UnifiedSymRep (SymType), + ) +import Grisette.Internal.Unified.Class.UnifiedSafeFdiv (UnifiedSafeFdiv) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.UnifiedInteger (GetInteger) +import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim) + +class + ( r ~ GetAlgReal mode, + UnifiedConRep r, + UnifiedSymRep r, + ConType r ~ AlgReal, + SymType r ~ SymAlgReal, + UnifiedBasicPrim mode r, + Prim r, + Num r, + Fractional r, + FdivOr r, + forall m. + (UnifiedBranching mode m, MonadError ArithException m) => + UnifiedSafeFdiv mode ArithException r m, + UnifiedFromIntegral mode (GetInteger mode) r + ) => + UnifiedAlgRealImpl (mode :: EvalModeTag) r + | mode -> r + where + -- | Get a unified algebraic real type. Resolves to 'AlgReal' in 'C' mode, + -- and 'SymAlgReal' in 'S' mode. + -- + -- 'Floating', 'Grisette.LogBaseOr' and 'Grisette.SafeLogBase' for + -- 'SymAlgReal' are not provided as they are not available for 'AlgReal'. + type GetAlgReal mode = real | real -> mode + +instance UnifiedAlgRealImpl 'C AlgReal where + type GetAlgReal 'C = AlgReal + +instance UnifiedAlgRealImpl 'S SymAlgReal where + type GetAlgReal 'S = SymAlgReal + +-- | Evaluation mode with unified 'AlgReal' type. +class + (UnifiedAlgRealImpl mode (GetAlgReal mode)) => + UnifiedAlgReal (mode :: EvalModeTag) + +instance UnifiedAlgReal 'C + +instance UnifiedAlgReal 'S diff --git a/src/Grisette/Internal/Unified/UnifiedBV.hs b/src/Grisette/Internal/Unified/UnifiedBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedBV.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedBV +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedBV + ( UnifiedBV, + UnifiedBVImpl (GetIntN, GetWordN), + AllUnifiedBV, + SafeUnifiedBV, + SafeUnifiedSomeBV, + GetSomeWordN, + GetSomeIntN, + SomeBVPair, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.UnifiedBV +import Grisette.Internal.Internal.Impl.Unified.UnifiedBV () diff --git a/src/Grisette/Internal/Unified/UnifiedBool.hs b/src/Grisette/Internal/Unified/UnifiedBool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedBool.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedBool +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedBool (UnifiedBool (..)) where + +import Grisette.Internal.Internal.Decl.Unified.UnifiedBool +import Grisette.Internal.Internal.Impl.Unified.UnifiedBool () diff --git a/src/Grisette/Internal/Unified/UnifiedData.hs b/src/Grisette/Internal/Unified/UnifiedData.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedData.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedData +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedData + ( GetData, + wrapData, + extractData, + UnifiedData, + AllUnifiedData, + ) +where + +import Control.DeepSeq (NFData) +import Control.Monad.Identity (Identity (Identity, runIdentity)) +import Data.Bytes.Serial (Serial) +import Data.Hashable (Hashable) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) +import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym) +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.SymPrim.AllSyms (AllSyms) +import Grisette.Internal.Unified.Class.UnifiedITEOp (UnifiedITEOp) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + UnifiedSimpleMergeable, + liftBaseMonad, + ) +import Grisette.Internal.Unified.Class.UnifiedSymEq (UnifiedSymEq) +import Grisette.Internal.Unified.Class.UnifiedSymOrd (UnifiedSymOrd) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift) + +class + ( u ~ GetData mode v, + (Mergeable v) => Mergeable u, + (AllSyms v) => AllSyms u, + (Eq v) => Eq u, + (EvalSym v) => EvalSym u, + (ExtractSym v) => ExtractSym u, + (ITEOp v, Mergeable v) => ITEOp u, + (PPrint v) => PPrint u, + (Hashable v) => Hashable u, + (Lift v) => Lift u, + (LogicalOp v, Mergeable v) => LogicalOp u, + (NFData v) => NFData u, + (Num v, Mergeable v) => Num u, + (SymEq v) => SymEq u, + (Show v) => Show u, + (SymOrd v) => SymOrd u, + (SubstSym v) => SubstSym u, + (Serial v, Mergeable v) => Serial u, + (UnifiedITEOp mode v, Mergeable v) => UnifiedITEOp mode u, + (UnifiedSimpleMergeable mode v, Mergeable v) => + UnifiedSimpleMergeable mode u, + (UnifiedSymEq mode v) => UnifiedSymEq mode u, + (UnifiedSymOrd mode v) => UnifiedSymOrd mode u, + forall a. (ToSym a v) => ToSym (Identity a) u, + forall a. (ToSym v a) => ToSym u (Union a), + forall a. (ToCon v a) => ToCon u (Identity a), + forall a. (ToCon a v) => ToCon (Union a) u + ) => + UnifiedDataImpl (mode :: EvalModeTag) v u + | u -> mode v + where + -- | Get a unified data type. Resolves to @v@ in 'C' mode, and @'Union' v@ + -- in 'S' mode. + type GetData mode v = r | r -> mode v + + -- | Wraps a value into the unified data type. + wrapData :: (Mergeable v) => v -> u + + -- | Extracts a value from the unified data type. + extractData :: (Mergeable v, Monad m, UnifiedBranching mode m) => u -> m v + +instance UnifiedDataImpl 'C v (Identity v) where + type GetData 'C v = Identity v + wrapData = Identity + extractData :: + forall m. (Mergeable v, Monad m, UnifiedBranching C m) => Identity v -> m v + extractData = withBaseBranching @'C @m $ return . runIdentity + +instance UnifiedDataImpl 'S v (Union v) where + type GetData 'S v = Union v + wrapData = mrgSingle + extractData :: + forall m. (Mergeable v, Monad m, UnifiedBranching S m) => Union v -> m v + extractData = liftBaseMonad + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Internal.Unified.IsMode.IsMode'. +class (UnifiedDataImpl mode v (GetData mode v)) => UnifiedData mode v + +instance (UnifiedDataImpl bool v (GetData bool v)) => UnifiedData bool v + +class + (UnifiedSimpleMergeable 'S (GetData 'S v)) => + UnifiedDataSimpleMergeable v + +instance (Mergeable v) => UnifiedDataSimpleMergeable v + +-- | Evaluation mode with unified data types. +class + ( forall v. UnifiedData bool v, + forall v. (Mergeable v) => UnifiedDataSimpleMergeable v + ) => + AllUnifiedData bool + +instance + ( forall v. UnifiedData bool v, + forall v. (Mergeable v) => UnifiedDataSimpleMergeable v + ) => + AllUnifiedData bool diff --git a/src/Grisette/Internal/Unified/UnifiedFP.hs b/src/Grisette/Internal/Unified/UnifiedFP.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedFP.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedFP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedFP + ( UnifiedFPImpl (GetFP, GetFPRoundingMode), + UnifiedFP, + SafeUnifiedFP, + AllUnifiedFP, + ) +where + +import Grisette.Internal.Internal.Decl.Unified.UnifiedFP +import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () diff --git a/src/Grisette/Internal/Unified/UnifiedFun.hs b/src/Grisette/Internal/Unified/UnifiedFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedFun.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedFun +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedFun + ( UnifiedFunConstraint, + UnifiedFun (..), + unifiedFunInstanceName, + genUnifiedFunInstance, + GetFun2, + GetFun3, + GetFun4, + GetFun5, + GetFun6, + GetFun7, + GetFun8, + ) +where + +#if MIN_VERSION_base(4,20,0) +#else +import Data.Foldable (Foldable (foldl')) +#endif + +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import Data.Bytes.Serial (Serial) +import Data.Hashable (Hashable) +import qualified Data.Kind +import Data.Serialize (Serialize) +import Data.Typeable (Typeable) +import GHC.TypeLits (KnownNat, Nat, type (<=)) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) +import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType), Function) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, ValidFP) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.Theories + ( TheoryToUnify (UAlgReal, UBool, UFP, UFun, UIntN, UInteger, UWordN), + ) +import Grisette.Internal.Unified.UnifiedAlgReal (GetAlgReal) +import Grisette.Internal.Unified.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN)) +import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Internal.Unified.UnifiedFP (UnifiedFPImpl (GetFP)) +import Grisette.Internal.Unified.UnifiedInteger (GetInteger) +import Language.Haskell.TH + ( DecsQ, + Pred, + Q, + TyLit (NumTyLit), + Type (AppT, ConT, ForallT, LitT, VarT), + appT, + classD, + conT, + instanceD, + mkName, + newName, + promotedT, + varT, + ) +import qualified Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr + ( kindedTV, + mapTVFlag, + specifiedSpec, + tvName, + ) +import Language.Haskell.TH.Syntax (Lift) + +#if MIN_VERSION_template_haskell(2,21,0) +type TyVarBndrVis = Language.Haskell.TH.TyVarBndrVis +#elif MIN_VERSION_template_haskell(2,17,0) +type TyVarBndrVis = Language.Haskell.TH.TyVarBndr () +#else +type TyVarBndrVis = Language.Haskell.TH.TyVarBndr +#endif + +-- | Provide unified function types. +class UnifiedFun (mode :: EvalModeTag) where + -- | Get a unified function type. Resolves to t'Grisette.SymPrim.=->' in 'C' + -- mode, and t'Grisette.SymPrim.=~>' in 'S' mode. + type + GetFun mode = + (fun :: Data.Kind.Type -> Data.Kind.Type -> Data.Kind.Type) | fun -> mode + +instance UnifiedFun 'C where + type GetFun 'C = (=->) + +instance UnifiedFun 'S where + type GetFun 'S = (=~>) + +-- | The unified function type with 2 arguments. +type GetFun2 mode a b = GetFun mode a b + +-- | The unified function type with 3 arguments. +type GetFun3 mode a b c = GetFun mode a (GetFun mode b c) + +-- | The unified function type with 4 arguments. +type GetFun4 mode a b c d = GetFun mode a (GetFun mode b (GetFun mode c d)) + +-- | The unified function type with 5 arguments. +type GetFun5 mode a b c d e = + GetFun mode a (GetFun mode b (GetFun mode c (GetFun mode d e))) + +-- | The unified function type with 6 arguments. +type GetFun6 mode a b c d e f = + GetFun + mode + a + (GetFun mode b (GetFun mode c (GetFun mode d (GetFun mode e f)))) + +-- | The unified function type with 7 arguments. +type GetFun7 mode a b c d e f g = + GetFun + mode + a + ( GetFun + mode + b + (GetFun mode c (GetFun mode d (GetFun mode e (GetFun mode f g)))) + ) + +-- | The unified function type with 8 arguments. +type GetFun8 mode a b c d e f g h = + GetFun + mode + a + ( GetFun + mode + b + ( GetFun + mode + c + (GetFun mode d (GetFun mode e (GetFun mode f (GetFun mode g h)))) + ) + ) + +-- | The constraint for a unified function. +type UnifiedFunConstraint mode a b ca cb sa sb = + ( Show (GetFun mode a b), + Binary (GetFun mode a b), + Serial (GetFun mode a b), + Serialize (GetFun mode a b), + NFData (GetFun mode a b), + Eq (GetFun mode a b), + EvalSym (GetFun mode a b), + ExtractSym (GetFun mode a b), + Mergeable (GetFun mode a b), + PPrint (GetFun mode a b), + SubstSym (GetFun mode a b), + Hashable (GetFun mode a b), + Lift (GetFun mode a b), + Typeable (GetFun mode a b), + ToCon (GetFun mode a b) (ca =-> cb), + ToCon (sa =~> sb) (GetFun mode a b), + ToSym (GetFun mode a b) (sa =~> sb), + ToSym (ca =-> cb) (GetFun mode a b), + Function (GetFun mode a b) a b, + Apply (GetFun mode a b), + FunType (GetFun mode a b) ~ (a -> b) + ) + +genInnerUnifiedFunInstance :: + String -> + TyVarBndrVis -> + [Pred] -> + [TyVarBndrVis] -> + [(Type, Type, Type)] -> + DecsQ +genInnerUnifiedFunInstance nm mode preds bndrs tys = do + x <- classD (goPred tys) (mkName nm) (mode : bndrs) [] [] + dc <- + instanceD + (return preds) + (applyTypeList (promotedT 'C : additionalTypes)) + [] + ds <- + instanceD + (return preds) + (applyTypeList (promotedT 'S : additionalTypes)) + [] + return [x, dc, ds] + where + additionalTypes = (varT . tvName) <$> bndrs + applyTypeList = foldl appT (conT (mkName nm)) + goPred :: [(Type, Type, Type)] -> Q [Pred] + goPred [] = fail "Empty list of function types, at least 2." + goPred [_] = return [] + goPred (x : xs) = do + p1 <- pred x xs + pr <- goPred xs + return $ p1 : pr + listTys :: [(Type, Type, Type)] -> Q (Type, Type, Type) + listTys [] = fail "Should not happen" + listTys [(u, c, s)] = return (u, c, s) + listTys ((u, c, s) : xs) = do + (u', c', s') <- listTys xs + return + ( AppT (AppT (AppT (ConT ''GetFun) (VarT $ tvName mode)) u) u', + AppT (AppT (ConT ''(=->)) c) c', + AppT (AppT (ConT ''(=~>)) s) s' + ) + pred (ua, ca, sa) l = do + (ub, cb, sb) <- listTys l + [t| + UnifiedFunConstraint + $(return (VarT $ tvName mode)) + $(return ua) + $(return ub) + $(return ca) + $(return cb) + $(return sa) + $(return sb) + |] + +genOuterUnifiedFunInstance :: + String -> String -> TyVarBndrVis -> [Pred] -> [TyVarBndrVis] -> DecsQ +genOuterUnifiedFunInstance nm innerName mode preds bndrs = do + let bndrs' = mapTVFlag (const specifiedSpec) <$> bndrs + x <- + classD + ( return + [ ForallT bndrs' preds $ + foldl' AppT (ConT $ mkName innerName) $ + VarT . tvName <$> mode : bndrs + ] + ) + (mkName nm) + [mode] + [] + [] + dc <- + instanceD + (return []) + (appT (conT $ mkName nm) (promotedT 'C)) + [] + ds <- + instanceD + (return []) + (appT (conT $ mkName nm) (promotedT 'S)) + [] + return [x, dc, ds] + +-- | Generate unified function instance names. +unifiedFunInstanceName :: String -> [TheoryToUnify] -> String +unifiedFunInstanceName prefix theories = + prefix ++ "Fun" ++ (concatMap show theories) + +-- | Generate unified function instances. +genUnifiedFunInstance :: String -> [TheoryToUnify] -> DecsQ +genUnifiedFunInstance prefix theories = do + modeName <- newName "mode" + let modeType = VarT modeName + allArgs <- traverse (genArgs modeType) theories + let baseName = unifiedFunInstanceName prefix theories + rinner <- + genInnerUnifiedFunInstance + baseName + (kindedTV modeName (ConT ''EvalModeTag)) + (concatMap (\(_, p, _, _, _) -> p) allArgs) + (concatMap (\(t, _, _, _, _) -> t) allArgs) + ((\(_, _, u, c, s) -> (u, c, s)) <$> allArgs) + router <- + if all (\(bndr, _, _, _, _) -> null bndr) allArgs + then return [] + else + genOuterUnifiedFunInstance + ("All" ++ baseName) + baseName + (kindedTV modeName (ConT ''EvalModeTag)) + (concatMap (\(_, p, _, _, _) -> p) allArgs) + (concatMap (\(t, _, _, _, _) -> t) allArgs) + return $ rinner ++ router + where + genArgs :: + Type -> TheoryToUnify -> Q ([TyVarBndrVis], [Pred], Type, Type, Type) + genArgs mode UBool = + return + ( [], + [], + AppT (ConT ''GetBool) mode, + ConT ''Bool, + ConT ''SymBool + ) + genArgs mode UIntN = do + n <- newName "n" + let nType = VarT n + return + ( [kindedTV n (ConT ''Nat)], + [ AppT (ConT ''KnownNat) nType, + AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType + ], + AppT (AppT (ConT ''GetIntN) mode) nType, + AppT (ConT ''IntN) nType, + AppT (ConT ''SymIntN) nType + ) + genArgs mode UWordN = do + n <- newName "n" + let nType = VarT n + return + ( [kindedTV n (ConT ''Nat)], + [ AppT (ConT ''KnownNat) nType, + AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType + ], + AppT (AppT (ConT ''GetWordN) mode) nType, + AppT (ConT ''WordN) nType, + AppT (ConT ''SymWordN) nType + ) + genArgs mode UInteger = + return + ( [], + [], + AppT (ConT ''GetInteger) mode, + ConT ''Integer, + ConT ''SymInteger + ) + genArgs mode UAlgReal = + return + ( [], + [], + AppT (ConT ''GetAlgReal) mode, + ConT ''AlgReal, + ConT ''SymAlgReal + ) + genArgs mode UFP = do + eb <- newName "eb" + sb <- newName "sb" + let ebType = VarT eb + let sbType = VarT sb + return + ( [kindedTV eb (ConT ''Nat), kindedTV sb (ConT ''Nat)], + [AppT (AppT (ConT ''ValidFP) ebType) sbType], + AppT (AppT (AppT (ConT ''GetFP) mode) ebType) sbType, + AppT (AppT (ConT ''FP) ebType) sbType, + AppT (AppT (ConT ''SymFP) ebType) sbType + ) + genArgs _ UFun {} = fail "UFun cannot be nested." diff --git a/src/Grisette/Internal/Unified/UnifiedInteger.hs b/src/Grisette/Internal/Unified/UnifiedInteger.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedInteger.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedInteger +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedInteger + ( GetInteger, + UnifiedInteger, + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Except (MonadError) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) +import Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (ConType), + UnifiedSymRep (SymType), + ) +import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv) +import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith + ( UnifiedSafeLinearArith, + ) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim) + +class + ( i ~ GetInteger mode, + UnifiedConRep i, + UnifiedSymRep i, + ConType i ~ Integer, + SymType i ~ SymInteger, + UnifiedBasicPrim mode i, + Num i, + forall m. + (UnifiedBranching mode m, MonadError ArithException m) => + UnifiedSafeDiv mode ArithException i m, + forall m. + (UnifiedBranching mode m, MonadError ArithException m) => + UnifiedSafeLinearArith mode ArithException i m, + UnifiedFromIntegral mode i i + ) => + UnifiedIntegerImpl (mode :: EvalModeTag) i + | mode -> i + where + -- | Get a unified Integer type. Resolves to 'Integer' in 'C' mode, and + -- 'SymInteger' in 'S' mode. + type GetInteger mode = int | int -> mode + +instance UnifiedIntegerImpl 'C Integer where + type GetInteger 'C = Integer + +instance UnifiedIntegerImpl 'S SymInteger where + type GetInteger 'S = SymInteger + +-- | Evaluation mode with unified 'Integer' type. +class + (UnifiedIntegerImpl mode (GetInteger mode)) => + UnifiedInteger (mode :: EvalModeTag) + +instance UnifiedInteger 'C + +instance UnifiedInteger 'S diff --git a/src/Grisette/Internal/Unified/UnifiedPrim.hs b/src/Grisette/Internal/Unified/UnifiedPrim.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/UnifiedPrim.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} + +-- | +-- Module : Grisette.Internal.Unified.UnifiedPrim +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.UnifiedPrim + ( UnifiedPrim, + UnifiedBasicPrim, + ) +where + +import Grisette.Internal.SymPrim.SymPrim (Prim) +import Grisette.Internal.Unified.BaseConstraint (ConSymConversion) +import Grisette.Internal.Unified.Class.UnifiedITEOp + ( UnifiedITEOp, + ) +import Grisette.Internal.Unified.Class.UnifiedRep + ( UnifiedConRep (ConType), + UnifiedSymRep (SymType), + ) +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable + ( UnifiedSimpleMergeable, + ) +import Grisette.Internal.Unified.Class.UnifiedSolvable (UnifiedSolvable) +import Grisette.Internal.Unified.Class.UnifiedSymEq (UnifiedSymEq) +import Grisette.Internal.Unified.Class.UnifiedSymOrd (UnifiedSymOrd) + +-- | A type that is used as a constraint for all the (unified) primitive types +-- in Grisette. +type UnifiedPrim mode a = + ( Prim a, + UnifiedITEOp mode a, + UnifiedSymEq mode a, + UnifiedSymOrd mode a + ) + +-- | A type that is used as a constraint for all the basic (unified) primitive +-- types in Grisette. +-- +-- 'Grisette.Internal.Unified.GetSomeWordN' is not considered as a basic (unified) +-- primitive type. +type UnifiedBasicPrim mode a = + ( UnifiedPrim mode a, + UnifiedSimpleMergeable mode a, + UnifiedConRep a, + UnifiedSymRep a, + UnifiedSolvable mode a (ConType a), + ConSymConversion (ConType a) (SymType a) a + ) diff --git a/src/Grisette/Internal/Unified/Util.hs b/src/Grisette/Internal/Unified/Util.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Unified/Util.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.Unified.Util +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Unified.Util + ( DecideEvalMode (..), + withMode, + EvalModeConvertible (..), + ) +where + +import Data.Typeable (type (:~:) (Refl)) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) +import Grisette.Internal.Utils.Parameterized (unsafeAxiom) + +-- | A class that provides the mode tag at runtime. +class DecideEvalMode (mode :: EvalModeTag) where + decideEvalMode :: EvalModeTag + +instance DecideEvalMode 'C where + decideEvalMode = C + {-# INLINE decideEvalMode #-} + +instance DecideEvalMode 'S where + decideEvalMode = S + {-# INLINE decideEvalMode #-} + +-- | Case analysis on the mode. +withMode :: + forall mode r. + (DecideEvalMode mode) => + ((mode ~ 'C) => r) -> + ((mode ~ 'S) => r) -> + r +withMode con sym = + case decideEvalMode @mode of + C -> case unsafeAxiom @mode @'C of + Refl -> con + S -> case unsafeAxiom @mode @'S of + Refl -> sym +{-# INLINE withMode #-} + +-- | A class saying that we can convert a value with one mode to another mode. +-- +-- Allowed conversions: +-- +-- - 'C' <-> 'C' +-- - 'S' <-> 'S' +-- - 'C' <-> 'S' +-- +-- Conversion from left to right uses 'Grisette.ToSym' class, and conversion +-- from right to left uses 'Grisette.ToCon' class. +class + (DecideEvalMode c, DecideEvalMode s) => + EvalModeConvertible (c :: EvalModeTag) (s :: EvalModeTag) + where + withModeConvertible :: + ((c ~ 'C) => r) -> + ((s ~ 'S) => r) -> + r + withModeConvertible' :: + ((c ~ 'C, s ~ 'C) => r) -> + ((c ~ 'C, s ~ 'S) => r) -> + ((c ~ 'S, s ~ 'S) => r) -> + r + +instance {-# INCOHERENT #-} (DecideEvalMode s) => EvalModeConvertible 'C s where + withModeConvertible con _ = con + {-# INLINE withModeConvertible #-} + withModeConvertible' con0 con1 _ = withMode @s con0 con1 + {-# INLINE withModeConvertible' #-} + +instance {-# INCOHERENT #-} (DecideEvalMode c) => EvalModeConvertible c 'S where + withModeConvertible _ sym = sym + {-# INLINE withModeConvertible #-} + withModeConvertible' _ sym0 sym1 = withMode @c sym0 sym1 + {-# INLINE withModeConvertible' #-} 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 @@ -94,6 +94,7 @@ TryMerge, ) import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) import Grisette.Lib.Data.Foldable ( mrgForM_, mrgMapM_, @@ -106,7 +107,6 @@ mrgMapM, mrgSequence, ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S)) import qualified Grisette.Unified.Lib.Control.Monad as Unified -- | 'return' with 'MergingStrategy' knowledge propagation. diff --git a/src/Grisette/TH.hs b/src/Grisette/TH.hs --- a/src/Grisette/TH.hs +++ b/src/Grisette/TH.hs @@ -10,12 +10,22 @@ -- Portability : GHC only module Grisette.TH ( -- * Convenient derivation of all instances relating to Grisette - derive, - deriveAll, - deriveAllExcept, + EvalModeConfig (..), + DeriveConfig (..), deriveGADT, - deriveGADTAll, - deriveGADTAllExcept, + deriveGADTWith, + allClasses0, + allClasses01, + allClasses012, + basicClasses0, + noExistentialClasses0, + ordClasses0, + basicClasses1, + noExistentialClasses1, + ordClasses1, + basicClasses2, + noExistentialClasses2, + ordClasses2, -- * Smart constructors that merges in a monad makePrefixedSmartCtor, @@ -28,33 +38,6 @@ makeNamedUnifiedCtor, makeUnifiedCtor, makeUnifiedCtorWith, - - -- * Tools for building more derivation procedures - - -- ** Type parameter handlers - DeriveTypeParamHandler (..), - IsFPBits (..), - NatShouldBePositive (..), - PrimaryConstraint (..), - SomeDeriveTypeParamHandler (..), - - -- ** Instance providers - DeriveInstanceProvider (..), - Strategy (..), - - -- ** For unified interfaces - TypeableMode (..), - PrimaryUnifiedConstraint (..), - UnifiedInstance (..), - - -- ** Other helpers - deriveWithHandlers, - derivePredefined, - derivePredefinedMultipleClasses, - deriveBuiltinExtra, - deriveUnifiedInterfaceExtra, - deriveUnifiedInterface1Extra, - deriveFunctorArgUnifiedInterfaceExtra, ) where @@ -70,34 +53,20 @@ makeUnifiedCtor, makeUnifiedCtorWith, ) -import Grisette.Internal.TH.DeriveBuiltin - ( deriveBuiltinExtra, - ) -import Grisette.Internal.TH.DeriveInstanceProvider - ( DeriveInstanceProvider (..), - Strategy (..), - ) -import Grisette.Internal.TH.DerivePredefined - ( derive, - deriveAll, - deriveAllExcept, - derivePredefined, - derivePredefinedMultipleClasses, - ) -import Grisette.Internal.TH.DeriveTypeParamHandler - ( DeriveTypeParamHandler (..), - IsFPBits (..), - NatShouldBePositive (..), - PrimaryConstraint (..), - SomeDeriveTypeParamHandler (..), - ) -import Grisette.Internal.TH.DeriveUnifiedInterface - ( PrimaryUnifiedConstraint (..), - TypeableMode (..), - UnifiedInstance (..), - deriveFunctorArgUnifiedInterfaceExtra, - deriveUnifiedInterface1Extra, - deriveUnifiedInterfaceExtra, +import Grisette.Internal.TH.GADT.Common (DeriveConfig (..), EvalModeConfig (..)) +import Grisette.Internal.TH.GADT.DeriveGADT + ( allClasses0, + allClasses01, + allClasses012, + basicClasses0, + basicClasses1, + basicClasses2, + deriveGADT, + deriveGADTWith, + noExistentialClasses0, + noExistentialClasses1, + noExistentialClasses2, + ordClasses0, + ordClasses1, + ordClasses2, ) -import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) -import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT, deriveGADTAll, deriveGADTAllExcept) diff --git a/src/Grisette/Unified.hs b/src/Grisette/Unified.hs --- a/src/Grisette/Unified.hs +++ b/src/Grisette/Unified.hs @@ -24,6 +24,9 @@ EvalModeAlgReal, EvalModeAll, MonadEvalModeAll, + DecideEvalMode (..), + withMode, + EvalModeConvertible (..), -- * Unified operations @@ -48,6 +51,8 @@ -- ** Unified SymEq UnifiedSymEq (..), + UnifiedSymEq1 (..), + UnifiedSymEq2 (..), (.==), (./=), symDistinct, @@ -58,6 +63,8 @@ -- ** Unified SymOrd UnifiedSymOrd (..), + UnifiedSymOrd1 (..), + UnifiedSymOrd2 (..), (.<=), (.<), (.>=), @@ -175,15 +182,15 @@ ) where -import Grisette.Unified.Internal.BVBVConversion +import Grisette.Internal.Unified.BVBVConversion ( UnifiedBVBVConversion, ) -import Grisette.Unified.Internal.BVFPConversion +import Grisette.Internal.Unified.BVFPConversion ( SafeUnifiedBVFPConversion, UnifiedBVFPConversion, ) -import Grisette.Unified.Internal.BaseMonad (BaseMonad) -import Grisette.Unified.Internal.Class.UnifiedFiniteBits +import Grisette.Internal.Unified.BaseMonad (BaseMonad) +import Grisette.Internal.Unified.Class.UnifiedFiniteBits ( UnifiedFiniteBits (..), symBitBlast, symCountLeadingZeros, @@ -195,20 +202,20 @@ symSetBitTo, symTestBit, ) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral +import Grisette.Internal.Unified.Class.UnifiedFromIntegral ( UnifiedFromIntegral (..), symFromIntegral, ) -import Grisette.Unified.Internal.Class.UnifiedITEOp +import Grisette.Internal.Unified.Class.UnifiedITEOp ( UnifiedITEOp (..), symIte, symIteMerge, ) -import Grisette.Unified.Internal.Class.UnifiedSafeBitCast +import Grisette.Internal.Unified.Class.UnifiedSafeBitCast ( UnifiedSafeBitCast (..), safeBitCast, ) -import Grisette.Unified.Internal.Class.UnifiedSafeDiv +import Grisette.Internal.Unified.Class.UnifiedSafeDiv ( UnifiedSafeDiv (..), safeDiv, safeDivMod, @@ -217,33 +224,33 @@ safeQuotRem, safeRem, ) -import Grisette.Unified.Internal.Class.UnifiedSafeFdiv +import Grisette.Internal.Unified.Class.UnifiedSafeFdiv ( UnifiedSafeFdiv (..), safeFdiv, ) -import Grisette.Unified.Internal.Class.UnifiedSafeFromFP +import Grisette.Internal.Unified.Class.UnifiedSafeFromFP ( UnifiedSafeFromFP (..), safeFromFP, ) -import Grisette.Unified.Internal.Class.UnifiedSafeLinearArith +import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith ( UnifiedSafeLinearArith (..), safeAdd, safeNeg, safeSub, ) -import Grisette.Unified.Internal.Class.UnifiedSafeSymRotate +import Grisette.Internal.Unified.Class.UnifiedSafeSymRotate ( UnifiedSafeSymRotate (..), safeSymRotateL, safeSymRotateR, ) -import Grisette.Unified.Internal.Class.UnifiedSafeSymShift +import Grisette.Internal.Unified.Class.UnifiedSafeSymShift ( UnifiedSafeSymShift (..), safeSymShiftL, safeSymShiftR, safeSymStrictShiftL, safeSymStrictShiftR, ) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable +import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable ( UnifiedBranching (..), UnifiedSimpleMergeable (..), UnifiedSimpleMergeable1 (..), @@ -257,8 +264,10 @@ mrgIte2, simpleMerge, ) -import Grisette.Unified.Internal.Class.UnifiedSymEq +import Grisette.Internal.Unified.Class.UnifiedSymEq ( UnifiedSymEq (..), + UnifiedSymEq1 (..), + UnifiedSymEq2 (..), liftSymEq, liftSymEq2, symDistinct, @@ -267,8 +276,10 @@ (./=), (.==), ) -import Grisette.Unified.Internal.Class.UnifiedSymOrd +import Grisette.Internal.Unified.Class.UnifiedSymOrd ( UnifiedSymOrd (..), + UnifiedSymOrd1 (..), + UnifiedSymOrd2 (..), liftSymCompare, liftSymCompare2, mrgMax, @@ -283,7 +294,7 @@ (.>), (.>=), ) -import Grisette.Unified.Internal.EvalMode +import Grisette.Internal.Unified.EvalMode ( EvalModeAlgReal, EvalModeAll, EvalModeBV, @@ -293,19 +304,19 @@ MonadEvalModeAll, genEvalMode, ) -import Grisette.Unified.Internal.EvalModeTag +import Grisette.Internal.Unified.EvalModeTag ( EvalModeTag (..), IsConMode, ) -import Grisette.Unified.Internal.FPFPConversion +import Grisette.Internal.Unified.FPFPConversion ( UnifiedFPFPConversion, ) -import Grisette.Unified.Internal.Theories (TheoryToUnify (..)) -import Grisette.Unified.Internal.UnifiedAlgReal +import Grisette.Internal.Unified.Theories (TheoryToUnify (..)) +import Grisette.Internal.Unified.UnifiedAlgReal ( GetAlgReal, UnifiedAlgReal, ) -import Grisette.Unified.Internal.UnifiedBV +import Grisette.Internal.Unified.UnifiedBV ( GetIntN, GetSomeIntN, GetSomeWordN, @@ -314,20 +325,20 @@ SafeUnifiedSomeBV, UnifiedBV, ) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (..)) -import Grisette.Unified.Internal.UnifiedData +import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (..)) +import Grisette.Internal.Unified.UnifiedData ( GetData, UnifiedData, extractData, wrapData, ) -import Grisette.Unified.Internal.UnifiedFP +import Grisette.Internal.Unified.UnifiedFP ( GetFP, GetFPRoundingMode, SafeUnifiedFP, UnifiedFP, ) -import Grisette.Unified.Internal.UnifiedFun +import Grisette.Internal.Unified.UnifiedFun ( GetFun, GetFun2, GetFun3, @@ -341,11 +352,16 @@ genUnifiedFunInstance, unifiedFunInstanceName, ) -import Grisette.Unified.Internal.UnifiedInteger +import Grisette.Internal.Unified.UnifiedInteger ( GetInteger, UnifiedInteger, ) -import Grisette.Unified.Internal.UnifiedPrim +import Grisette.Internal.Unified.UnifiedPrim ( UnifiedBasicPrim, UnifiedPrim, + ) +import Grisette.Internal.Unified.Util + ( DecideEvalMode (..), + EvalModeConvertible (..), + withMode, ) diff --git a/src/Grisette/Unified/Internal/BVBVConversion.hs b/src/Grisette/Unified/Internal/BVBVConversion.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/BVBVConversion.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.BVBVConversion --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.BVBVConversion - ( UnifiedBVBVConversion, - AllUnifiedBVBVConversion, - ) -where - -import GHC.TypeNats (KnownNat, Nat, type (<=)) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral (UnifiedFromIntegral) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN)) - -class - ( bv0 ~ bvn0 n0, - bv1 ~ bvn1 n1, - UnifiedFromIntegral mode bv0 bv1 - ) => - UnifiedBVBVConversionImpl - (mode :: EvalModeTag) - bvn0 - bvn1 - (n0 :: Nat) - (n1 :: Nat) - bv0 - bv1 - | bvn0 n0 -> bv0, - bvn1 n1 -> bv1, - bv0 -> bvn0 n0, - bv1 -> bvn1 n1 - -#define QUOTE() ' - -#define CONINSTANCE(ty0, ty1) \ -instance \ - (KnownNat n0, 1 <= n0, KnownNat n1, 1 <= n1) => \ - UnifiedBVBVConversionImpl QUOTE()C ty0 ty1 n0 n1 (ty0 n0) (ty1 n1) - -#define SYMINSTANCE(ty0, ty1) \ -instance \ - (KnownNat n0, 1 <= n0, KnownNat n1, 1 <= n1) => \ - UnifiedBVBVConversionImpl QUOTE()S ty0 ty1 n0 n1 (ty0 n0) (ty1 n1) - -#if 1 -CONINSTANCE(WordN, WordN) -CONINSTANCE(WordN, IntN) -CONINSTANCE(IntN, WordN) -CONINSTANCE(IntN, IntN) -SYMINSTANCE(SymWordN, SymWordN) -SYMINSTANCE(SymWordN, SymIntN) -SYMINSTANCE(SymIntN, SymWordN) -SYMINSTANCE(SymIntN, SymIntN) -#endif - --- | Unified constraints for conversion between bit-vectors. -class - ( UnifiedBVBVConversionImpl - mode - (GetWordN mode) - (GetWordN mode) - n0 - n1 - (GetWordN mode n0) - (GetWordN mode n1), - UnifiedBVBVConversionImpl - mode - (GetWordN mode) - (GetIntN mode) - n0 - n1 - (GetWordN mode n0) - (GetIntN mode n1), - UnifiedBVBVConversionImpl - mode - (GetIntN mode) - (GetWordN mode) - n0 - n1 - (GetIntN mode n0) - (GetWordN mode n1), - UnifiedBVBVConversionImpl - mode - (GetIntN mode) - (GetIntN mode) - n0 - n1 - (GetIntN mode n0) - (GetIntN mode n1) - ) => - UnifiedBVBVConversion (mode :: EvalModeTag) n0 n1 - -instance - ( UnifiedBVBVConversionImpl - mode - (GetWordN mode) - (GetWordN mode) - n0 - n1 - (GetWordN mode n0) - (GetWordN mode n1), - UnifiedBVBVConversionImpl - mode - (GetWordN mode) - (GetIntN mode) - n0 - n1 - (GetWordN mode n0) - (GetIntN mode n1), - UnifiedBVBVConversionImpl - mode - (GetIntN mode) - (GetWordN mode) - n0 - n1 - (GetIntN mode n0) - (GetWordN mode n1), - UnifiedBVBVConversionImpl - mode - (GetIntN mode) - (GetIntN mode) - n0 - n1 - (GetIntN mode n0) - (GetIntN mode n1) - ) => - UnifiedBVBVConversion (mode :: EvalModeTag) n0 n1 - --- | Evaluation mode with unified conversion from bit-vectors to bit-vectors. -class - ( forall n0 n1. - (KnownNat n0, KnownNat n1, 1 <= n0, 1 <= n1) => - UnifiedBVBVConversion mode n0 n1 - ) => - AllUnifiedBVBVConversion mode - -instance - ( forall n0 n1. - (KnownNat n0, KnownNat n1, 1 <= n0, 1 <= n1) => - UnifiedBVBVConversion mode n0 n1 - ) => - AllUnifiedBVBVConversion mode diff --git a/src/Grisette/Unified/Internal/BVFPConversion.hs b/src/Grisette/Unified/Internal/BVFPConversion.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/BVFPConversion.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.BVFPConversion --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.BVFPConversion - ( UnifiedBVFPConversion, - SafeUnifiedBVFPConversion, - AllUnifiedBVFPConversion, - ) -where - -import Control.Monad.Error.Class (MonadError) -import GHC.TypeLits (KnownNat, type (+), type (<=)) -import Grisette.Internal.Core.Data.Class.BitCast - ( BitCast, - BitCastCanonical, - BitCastOr, - ) -import Grisette.Internal.Core.Data.Class.IEEEFP - ( IEEEFPConvertible, - ) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral (UnifiedFromIntegral) -import Grisette.Unified.Internal.Class.UnifiedSafeBitCast (UnifiedSafeBitCast) -import Grisette.Unified.Internal.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN)) -import Grisette.Unified.Internal.UnifiedFP - ( UnifiedFPImpl (GetFP, GetFPRoundingMode), - ) - -class - ( UnifiedBVImpl mode wordn intn n word int, - UnifiedFPImpl mode fpn eb sb fp fprd, - BitCast word fp, - BitCast int fp, - BitCastOr fp word, - BitCastOr fp int, - BitCastCanonical fp word, - BitCastCanonical fp int, - UnifiedFromIntegral mode word fp, - UnifiedFromIntegral mode int fp, - IEEEFPConvertible int fp fprd, - IEEEFPConvertible word fp fprd - ) => - UnifiedBVFPConversionImpl - (mode :: EvalModeTag) - wordn - intn - fpn - n - eb - sb - word - int - fp - fprd - -instance - (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => - UnifiedBVFPConversionImpl - 'C - WordN - IntN - FP - n - eb - sb - (WordN n) - (IntN n) - (FP eb sb) - FPRoundingMode - -instance - (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => - UnifiedBVFPConversionImpl - 'S - SymWordN - SymIntN - SymFP - n - eb - sb - (SymWordN n) - (SymIntN n) - (SymFP eb sb) - SymFPRoundingMode - -class - ( UnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd, - UnifiedSafeBitCast mode NotRepresentableFPError fp int m, - UnifiedSafeBitCast mode NotRepresentableFPError fp word m, - UnifiedSafeFromFP mode NotRepresentableFPError word fp fprd m - ) => - SafeUnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd m - -instance - ( UnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd, - UnifiedSafeBitCast mode NotRepresentableFPError fp int m, - UnifiedSafeBitCast mode NotRepresentableFPError fp word m, - UnifiedSafeFromFP mode NotRepresentableFPError word fp fprd m - ) => - SafeUnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd m - --- | Unified constraints for safe conversion from bit-vectors to floating point --- numbers. -class - ( SafeUnifiedBVFPConversionImpl - mode - (GetWordN mode) - (GetIntN mode) - (GetFP mode) - n - eb - sb - (GetWordN mode n) - (GetIntN mode n) - (GetFP mode eb sb) - (GetFPRoundingMode mode) - m - ) => - SafeUnifiedBVFPConversion mode n eb sb m - -instance - ( SafeUnifiedBVFPConversionImpl - mode - (GetWordN mode) - (GetIntN mode) - (GetFP mode) - n - eb - sb - (GetWordN mode n) - (GetIntN mode n) - (GetFP mode eb sb) - (GetFPRoundingMode mode) - m - ) => - SafeUnifiedBVFPConversion mode n eb sb m - --- | Unified constraints for conversion from bit-vectors to floating point --- numbers. -class - ( UnifiedBVFPConversionImpl - (mode :: EvalModeTag) - (GetWordN mode) - (GetIntN mode) - (GetFP mode) - n - eb - sb - (GetWordN mode n) - (GetIntN mode n) - (GetFP mode eb sb) - (GetFPRoundingMode mode) - ) => - UnifiedBVFPConversion mode n eb sb - -instance - ( UnifiedBVFPConversionImpl - (mode :: EvalModeTag) - (GetWordN mode) - (GetIntN mode) - (GetFP mode) - n - eb - sb - (GetWordN mode n) - (GetIntN mode n) - (GetFP mode eb sb) - (GetFPRoundingMode mode) - ) => - UnifiedBVFPConversion mode n eb sb - --- | Evaluation mode with unified conversion from bit-vectors to --- floating-points. -class - ( forall n eb sb. - (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => - UnifiedBVFPConversion mode n eb sb, - forall n eb sb m. - ( UnifiedBranching mode m, - ValidFP eb sb, - KnownNat n, - 1 <= n, - n ~ (eb + sb), - MonadError NotRepresentableFPError m - ) => - SafeUnifiedBVFPConversion mode n eb sb m - ) => - AllUnifiedBVFPConversion mode - -instance - ( forall n eb sb. - (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) => - UnifiedBVFPConversion mode n eb sb, - forall n eb sb m. - ( UnifiedBranching mode m, - ValidFP eb sb, - KnownNat n, - 1 <= n, - n ~ (eb + sb), - MonadError NotRepresentableFPError m - ) => - SafeUnifiedBVFPConversion mode n eb sb m - ) => - AllUnifiedBVFPConversion mode diff --git a/src/Grisette/Unified/Internal/BaseConstraint.hs b/src/Grisette/Unified/Internal/BaseConstraint.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/BaseConstraint.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} - --- | --- Module : Grisette.Unified.Internal.EvaluationMode --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.BaseConstraint - ( ConSymConversion, - ) -where - -import Grisette.Internal.Core.Data.Class.ToCon (ToCon) -import Grisette.Internal.Core.Data.Class.ToSym (ToSym) - --- | A type that is used as a constraint for all the types in Grisette that can --- be converted between concrete and symbolic types. -type ConSymConversion conType symType t = - ( ToCon t conType, - ToSym conType t, - ToCon symType t, - ToSym t symType - ) diff --git a/src/Grisette/Unified/Internal/BaseMonad.hs b/src/Grisette/Unified/Internal/BaseMonad.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/BaseMonad.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilyDependencies #-} - --- | --- Module : Grisette.Unified.Internal.BaseMonad --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.BaseMonad - ( BaseMonad, - ) -where - -import Control.Monad.Identity (Identity) -import Data.Kind (Type) -import Grisette.Internal.Core.Control.Monad.Union (Union) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) - --- | A type family that specifies the base monad for the evaluation mode. --- --- Resolves to 'Identity' for `C` mode, and 'Union' for `S` mode. -type family - BaseMonad (mode :: EvalModeTag) = - (r :: Type -> Type) | r -> mode - where - BaseMonad 'C = Identity - BaseMonad 'S = Union diff --git a/src/Grisette/Unified/Internal/Class/UnifiedFiniteBits.hs b/src/Grisette/Unified/Internal/Class/UnifiedFiniteBits.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedFiniteBits.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedFiniteBits --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedFiniteBits - ( UnifiedFiniteBits (..), - symTestBit, - symSetBitTo, - symFromBits, - symBitBlast, - symLsb, - symMsb, - symPopCount, - symCountLeadingZeros, - symCountTrailingZeros, - ) -where - -import Data.Bits - ( Bits (popCount, testBit), - FiniteBits (countLeadingZeros, countTrailingZeros), - ) -import Data.Data (Typeable) -import Data.Type.Bool (If) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SymFiniteBits - ( FromBits, - SymFiniteBits, - setBitTo, - ) -import qualified Grisette.Internal.Core.Data.Class.SymFiniteBits as SymFiniteBits -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.SomeBV - ( SomeIntN, - SomeSymIntN, - SomeSymWordN, - SomeWordN, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Unified.Internal.Class.UnifiedITEOp - ( UnifiedITEOp (withBaseITEOp), - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S), IsConMode) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symTestBit`. -symTestBit :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a) => - a -> - Int -> - GetBool mode -symTestBit a i = - withMode @mode - (withBaseFiniteBits @mode @a (testBit a i)) - (withBaseFiniteBits @mode @a (SymFiniteBits.symTestBit a i)) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symSetBitTo`. -symSetBitTo :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a) => - a -> - Int -> - GetBool mode -> - a -symSetBitTo a i b = - withMode @mode - (withBaseFiniteBits @mode @a (setBitTo a i b)) - (withBaseFiniteBits @mode @a (SymFiniteBits.symSetBitTo a i b)) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symFromBits`. -symFromBits :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a) => - [GetBool mode] -> - a -symFromBits bits = - withMode @mode - (withBaseFiniteBits @mode @a (SymFiniteBits.fromBits bits)) - (withBaseFiniteBits @mode @a (SymFiniteBits.symFromBits bits)) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symBitBlast`. -symBitBlast :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a) => - a -> - [GetBool mode] -symBitBlast a = - withMode @mode - (withBaseFiniteBits @mode @a (SymFiniteBits.bitBlast a)) - (withBaseFiniteBits @mode @a (SymFiniteBits.symBitBlast a)) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symLsb`. -symLsb :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a) => - a -> - GetBool mode -symLsb a = - withMode @mode - (withBaseFiniteBits @mode @a (SymFiniteBits.lsb a)) - (withBaseFiniteBits @mode @a (SymFiniteBits.symLsb a)) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symMsb`. -symMsb :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a) => - a -> - GetBool mode -symMsb a = - withMode @mode - (withBaseFiniteBits @mode @a (SymFiniteBits.msb a)) - (withBaseFiniteBits @mode @a (SymFiniteBits.symMsb a)) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symPopCount`. -symPopCount :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) => - a -> - a -symPopCount a = - withMode @mode - (withBaseFiniteBits @mode @a (fromIntegral $ popCount a)) - ( withBaseFiniteBits @mode @a $ - withBaseITEOp @mode @a (SymFiniteBits.symPopCount a) - ) - --- | Unified --- `Grisette.Internal.Core.Data.Class.SymFiniteBits.symCountLeadingZeros`. -symCountLeadingZeros :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) => - a -> - a -symCountLeadingZeros a = - withMode @mode - (withBaseFiniteBits @mode @a (fromIntegral $ countLeadingZeros a)) - ( withBaseFiniteBits @mode @a $ - withBaseITEOp @mode @a (SymFiniteBits.symCountLeadingZeros a) - ) - --- | Unified --- `Grisette.Internal.Core.Data.Class.SymFiniteBits.symCountTrailingZeros`. -symCountTrailingZeros :: - forall mode a. - (Typeable mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) => - a -> - a -symCountTrailingZeros a = - withMode @mode - (withBaseFiniteBits @mode @a (fromIntegral $ countTrailingZeros a)) - ( withBaseFiniteBits @mode @a $ - withBaseITEOp @mode @a (SymFiniteBits.symCountTrailingZeros a) - ) - --- | A class that provides unified equality comparison. --- --- We use this type class to help resolve the constraints for `FiniteBits`, --- `FromBits` and `SymFiniteBits`. -class UnifiedFiniteBits mode a where - withBaseFiniteBits :: - ((If (IsConMode mode) (FiniteBits a, FromBits a) (SymFiniteBits a)) => r) -> - r - -instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'C (WordN n) where - withBaseFiniteBits r = r - -instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'C (IntN n) where - withBaseFiniteBits r = r - -instance UnifiedFiniteBits 'C SomeWordN where - withBaseFiniteBits r = r - -instance UnifiedFiniteBits 'C SomeIntN where - withBaseFiniteBits r = r - -instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'S (SymWordN n) where - withBaseFiniteBits r = r - -instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'S (SymIntN n) where - withBaseFiniteBits r = r - -instance UnifiedFiniteBits 'S SomeSymWordN where - withBaseFiniteBits r = r - -instance UnifiedFiniteBits 'S SomeSymIntN where - withBaseFiniteBits r = r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedFromIntegral.hs b/src/Grisette/Unified/Internal/Class/UnifiedFromIntegral.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedFromIntegral.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedFromIntegral --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedFromIntegral - ( UnifiedFromIntegral (..), - symFromIntegral, - ) -where - -import Data.Type.Bool (If) -import Data.Typeable (Typeable) -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SymFromIntegral (SymFromIntegral) -import qualified Grisette.Internal.Core.Data.Class.SymFromIntegral as SymFromIntegral -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, ValidFP) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymFP (SymFP) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S), IsConMode) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SymFromIntegral.symFromIntegral` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > symFromIntegral @mode a -symFromIntegral :: - forall mode a b. (Typeable mode, UnifiedFromIntegral mode a b) => a -> b -symFromIntegral a = - withMode @mode - (withBaseFromIntegral @mode @a @b $ fromIntegral a) - (withBaseFromIntegral @mode @a @b $ SymFromIntegral.symFromIntegral a) - --- | A class that provides unified conversion from integral types. --- --- We use this type class to help resolve the constraints for `SymFromIntegral`. -class UnifiedFromIntegral (mode :: EvalModeTag) a b where - withBaseFromIntegral :: - ((If (IsConMode mode) (Integral a, Num b) (SymFromIntegral a b)) => r) -> r - -instance - {-# INCOHERENT #-} - ( Typeable mode, - (If (IsConMode mode) (Integral a, Num b) (SymFromIntegral a b)) - ) => - UnifiedFromIntegral mode a b - where - withBaseFromIntegral r = r - -instance UnifiedFromIntegral 'C Integer AlgReal where - withBaseFromIntegral r = r - -instance UnifiedFromIntegral 'C Integer Integer where - withBaseFromIntegral r = r - -instance (KnownNat n, 1 <= n) => UnifiedFromIntegral 'C Integer (IntN n) where - withBaseFromIntegral r = r - -instance - (KnownNat n, 1 <= n) => - UnifiedFromIntegral 'C Integer (WordN n) - where - withBaseFromIntegral r = r - -instance (ValidFP eb sb) => UnifiedFromIntegral 'C Integer (FP eb sb) where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'C (IntN n') AlgReal - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'C (IntN n') Integer - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'C (IntN n') (IntN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'C (IntN n') (WordN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', ValidFP eb sb) => - UnifiedFromIntegral 'C (IntN n') (FP eb sb) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'C (WordN n') AlgReal - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'C (WordN n') Integer - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'C (WordN n') (IntN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'C (WordN n') (WordN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', ValidFP eb sb) => - UnifiedFromIntegral 'C (WordN n') (FP eb sb) - where - withBaseFromIntegral r = r - -instance UnifiedFromIntegral 'S SymInteger SymAlgReal where - withBaseFromIntegral r = r - -instance UnifiedFromIntegral 'S SymInteger SymInteger where - withBaseFromIntegral r = r - -instance (KnownNat n, 1 <= n) => UnifiedFromIntegral 'S SymInteger (SymIntN n) where - withBaseFromIntegral r = r - -instance - (KnownNat n, 1 <= n) => - UnifiedFromIntegral 'S SymInteger (SymWordN n) - where - withBaseFromIntegral r = r - -instance (ValidFP eb sb) => UnifiedFromIntegral 'S SymInteger (SymFP eb sb) where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'S (SymIntN n') SymAlgReal - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'S (SymIntN n') SymInteger - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'S (SymIntN n') (SymIntN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'S (SymIntN n') (SymWordN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', ValidFP eb sb) => - UnifiedFromIntegral 'S (SymIntN n') (SymFP eb sb) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'S (SymWordN n') SymAlgReal - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n') => - UnifiedFromIntegral 'S (SymWordN n') SymInteger - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'S (SymWordN n') (SymIntN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', KnownNat n, 1 <= n) => - UnifiedFromIntegral 'S (SymWordN n') (SymWordN n) - where - withBaseFromIntegral r = r - -instance - (KnownNat n', 1 <= n', ValidFP eb sb) => - UnifiedFromIntegral 'S (SymWordN n') (SymFP eb sb) - where - withBaseFromIntegral r = r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedITEOp.hs b/src/Grisette/Unified/Internal/Class/UnifiedITEOp.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedITEOp.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Eta reduce" #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedITEOp --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedITEOp - ( symIte, - symIteMerge, - UnifiedITEOp (..), - ) -where - -import Control.Monad.Identity (Identity (runIdentity)) -import Data.Kind (Constraint) -import Data.Type.Bool (If) -import Data.Typeable (Typeable) -import Grisette.Internal.Core.Control.Monad.Union (Union) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) -import qualified Grisette.Internal.Core.Data.Class.ITEOp -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import qualified Grisette.Internal.Core.Data.Class.PlainUnion -import Grisette.Unified.Internal.BaseMonad (BaseMonad) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S), IsConMode) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.ITEOp.symIte` operation. --- --- This function isn't able to infer the mode of the boolean variable, so you --- need to provide the mode explicitly. For example: --- --- > symIte @mode (a .== b) ... --- > symIte (a .== b :: SymBool) ... --- > symIte (a .== b :: GetBool mode) ... -symIte :: - forall mode v. - (Typeable mode, UnifiedITEOp mode v) => - GetBool mode -> - v -> - v -> - v -symIte c a b = - withMode @mode - (withBaseITEOp @mode @v $ if c then a else b) - ( withBaseITEOp @mode @v $ - Grisette.Internal.Core.Data.Class.ITEOp.symIte c a b - ) - --- | Unified `Grisette.Internal.Core.Data.Class.PlainUnion.symIteMerge` --- operation. --- --- This function isn't able to infer the mode of the base monad from the result, --- so you need to provide the mode explicitly. For example: --- --- > symIteMerge @mode ... --- > symIteMerge (... :: BaseMonad mode v) ... -symIteMerge :: - forall mode v. - (Typeable mode, UnifiedITEOp mode v, Mergeable v) => - BaseMonad mode v -> - v -symIteMerge m = - withMode @mode - (withBaseITEOp @mode @v $ runIdentity m) - ( withBaseITEOp @mode @v $ - Grisette.Internal.Core.Data.Class.PlainUnion.symIteMerge m - ) - --- | A class that provides unified equality comparison. --- --- We use this type class to help resolve the constraints for `ITEOp`. -class UnifiedITEOp mode v where - withBaseITEOp :: - ((If (IsConMode mode) (() :: Constraint) (ITEOp v)) => r) -> r - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (() :: Constraint) (ITEOp a) - ) => - UnifiedITEOp mode a - where - withBaseITEOp r = withMode @mode r r - {-# INLINE withBaseITEOp #-} - -instance (Mergeable v, UnifiedITEOp 'S v) => UnifiedITEOp 'S (Union v) where - withBaseITEOp r = withBaseITEOp @'S @v r - {-# INLINE withBaseITEOp #-} diff --git a/src/Grisette/Unified/Internal/Class/UnifiedRep.hs b/src/Grisette/Unified/Internal/Class/UnifiedRep.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedRep.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedRep --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedRep - ( UnifiedConRep (..), - UnifiedSymRep (..), - ) -where - -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, ValidFP) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) - --- | A class that gives the concrete type of a unified primitive type. -class UnifiedConRep a where - type ConType a - --- | A class that gives the symbolic type of a unified primitive type. -class UnifiedSymRep a where - type SymType a - -instance UnifiedConRep Bool where - type ConType Bool = Bool - -instance UnifiedSymRep Bool where - type SymType Bool = SymBool - -instance UnifiedConRep SymBool where - type ConType SymBool = Bool - -instance UnifiedSymRep SymBool where - type SymType SymBool = SymBool - -instance UnifiedConRep Integer where - type ConType Integer = Integer - -instance UnifiedSymRep Integer where - type SymType Integer = SymInteger - -instance UnifiedConRep SymInteger where - type ConType SymInteger = Integer - -instance UnifiedSymRep SymInteger where - type SymType SymInteger = SymInteger - -instance UnifiedConRep AlgReal where - type ConType AlgReal = AlgReal - -instance UnifiedSymRep AlgReal where - type SymType AlgReal = SymAlgReal - -instance UnifiedConRep SymAlgReal where - type ConType SymAlgReal = AlgReal - -instance UnifiedSymRep SymAlgReal where - type SymType SymAlgReal = SymAlgReal - -instance (KnownNat n, 1 <= n) => UnifiedConRep (IntN n) where - type ConType (IntN n) = IntN n - -instance (KnownNat n, 1 <= n) => UnifiedSymRep (IntN n) where - type SymType (IntN n) = SymIntN n - -instance (KnownNat n, 1 <= n) => UnifiedConRep (SymIntN n) where - type ConType (SymIntN n) = IntN n - -instance (KnownNat n, 1 <= n) => UnifiedSymRep (SymIntN n) where - type SymType (SymIntN n) = SymIntN n - -instance (KnownNat n, 1 <= n) => UnifiedConRep (WordN n) where - type ConType (WordN n) = WordN n - -instance (KnownNat n, 1 <= n) => UnifiedSymRep (WordN n) where - type SymType (WordN n) = SymWordN n - -instance (KnownNat n, 1 <= n) => UnifiedConRep (SymWordN n) where - type ConType (SymWordN n) = WordN n - -instance (KnownNat n, 1 <= n) => UnifiedSymRep (SymWordN n) where - type SymType (SymWordN n) = SymWordN n - -instance (ValidFP eb sb) => UnifiedConRep (FP eb sb) where - type ConType (FP eb sb) = FP eb sb - -instance (ValidFP eb sb) => UnifiedSymRep (FP eb sb) where - type SymType (FP eb sb) = SymFP eb sb - -instance (ValidFP eb sb) => UnifiedConRep (SymFP eb sb) where - type ConType (SymFP eb sb) = FP eb sb - -instance (ValidFP eb sb) => UnifiedSymRep (SymFP eb sb) where - type SymType (SymFP eb sb) = SymFP eb sb diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeBitCast.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeBitCast.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeBitCast.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Eta reduce" #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeBitCast --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeBitCast - ( safeBitCast, - UnifiedSafeBitCast (..), - ) -where - -import Control.Monad.Error.Class (MonadError) -import Data.Typeable (Typeable) -import GHC.TypeLits (KnownNat, type (+), type (<=)) -import Grisette.Internal.Core.Data.Class.SafeBitCast (SafeBitCast) -import qualified Grisette.Internal.Core.Data.Class.SafeBitCast -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, NotRepresentableFPError, ValidFP) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymFP (SymFP) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSub @mode a b -safeBitCast :: - forall mode e a b m. - ( MonadError e m, - UnifiedSafeBitCast mode e a b m - ) => - a -> - m b -safeBitCast a = - withBaseSafeBitCast @mode @e @a @b @m $ - Grisette.Internal.Core.Data.Class.SafeBitCast.safeBitCast a -{-# INLINE safeBitCast #-} - --- | A class that provides unified safe bitcast operations. --- --- We use this type class to help resolve the constraints for `SafeBitCast`. -class UnifiedSafeBitCast (mode :: EvalModeTag) e a b m where - withBaseSafeBitCast :: ((SafeBitCast e a b m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeBitCast e a b m) => - UnifiedSafeBitCast mode e a b m - where - withBaseSafeBitCast r = r - -instance - ( Typeable mode, - MonadError NotRepresentableFPError m, - UnifiedBranching mode m, - ValidFP eb sb, - KnownNat n, - 1 <= n, - n ~ (eb + sb) - ) => - UnifiedSafeBitCast mode NotRepresentableFPError (FP eb sb) (WordN n) m - where - withBaseSafeBitCast r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( Typeable mode, - MonadError NotRepresentableFPError m, - UnifiedBranching mode m, - ValidFP eb sb, - KnownNat n, - 1 <= n, - n ~ (eb + sb) - ) => - UnifiedSafeBitCast mode NotRepresentableFPError (FP eb sb) (IntN n) m - where - withBaseSafeBitCast r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching 'S m, - ValidFP eb sb, - KnownNat n, - 1 <= n, - n ~ (eb + sb) - ) => - UnifiedSafeBitCast 'S NotRepresentableFPError (SymFP eb sb) (SymWordN n) m - where - withBaseSafeBitCast r = withBaseBranching @'S @m r - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching 'S m, - ValidFP eb sb, - KnownNat n, - 1 <= n, - n ~ (eb + sb) - ) => - UnifiedSafeBitCast 'S NotRepresentableFPError (SymFP eb sb) (SymIntN n) m - where - withBaseSafeBitCast r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeDiv.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeDiv.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeDiv.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# HLINT ignore "Eta reduce" #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeDiv --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeDiv - ( safeDiv, - safeMod, - safeDivMod, - safeQuot, - safeRem, - safeQuotRem, - UnifiedSafeDiv (..), - ) -where - -import Control.Monad.Error.Class (MonadError) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SafeDiv - ( ArithException, - SafeDiv, - ) -import qualified Grisette.Internal.Core.Data.Class.SafeDiv -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.SomeBV - ( SomeBVException, - SomeIntN, - SomeSymIntN, - SomeSymWordN, - SomeWordN, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (S), - ) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeDiv` operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeDiv @mode a b -safeDiv :: - forall mode e a m. - (MonadError e m, UnifiedSafeDiv mode e a m) => - a -> - a -> - m a -safeDiv a b = - withBaseSafeDiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeDiv.safeDiv a b -{-# INLINE safeDiv #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeMod` operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeMod @mode a b -safeMod :: - forall mode e a m. - (MonadError e m, UnifiedSafeDiv mode e a m) => - a -> - a -> - m a -safeMod a b = - withBaseSafeDiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeDiv.safeMod a b -{-# INLINE safeMod #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeDivMod` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeDivMod @mode a b -safeDivMod :: - forall mode e a m. - (MonadError e m, UnifiedSafeDiv mode e a m) => - a -> - a -> - m (a, a) -safeDivMod a b = - withBaseSafeDiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeDiv.safeDivMod a b -{-# INLINE safeDivMod #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeQuot` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeQuot @mode a b -safeQuot :: - forall mode e a m. - (MonadError e m, UnifiedSafeDiv mode e a m) => - a -> - a -> - m a -safeQuot a b = - withBaseSafeDiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeDiv.safeQuot a b -{-# INLINE safeQuot #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeRem` operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeRem @mode a b -safeRem :: - forall mode e a m. - (MonadError e m, UnifiedSafeDiv mode e a m) => - a -> - a -> - m a -safeRem a b = - withBaseSafeDiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeDiv.safeRem a b -{-# INLINE safeRem #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.safeQuotRem` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeQuotRem @mode a b -safeQuotRem :: - forall mode e a m. - (MonadError e m, UnifiedSafeDiv mode e a m) => - a -> - a -> - m (a, a) -safeQuotRem a b = - withBaseSafeDiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeDiv.safeQuotRem a b -{-# INLINE safeQuotRem #-} - --- | A class that provides unified division operations. --- --- We use this type class to help resolve the constraints for `SafeDiv`. -class UnifiedSafeDiv (mode :: EvalModeTag) e a m where - withBaseSafeDiv :: ((SafeDiv e a m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeDiv e a m) => - UnifiedSafeDiv mode e a m - where - withBaseSafeDiv r = r - -instance - (MonadError ArithException m, UnifiedBranching mode m) => - UnifiedSafeDiv mode ArithException Integer m - where - withBaseSafeDiv r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m) => - UnifiedSafeDiv 'S ArithException SymInteger m - where - withBaseSafeDiv r = withBaseBranching @'S @m r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeDiv mode ArithException (IntN n) m - where - withBaseSafeDiv r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeDiv 'S ArithException (SymIntN n) m - where - withBaseSafeDiv r = withBaseBranching @'S @m r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeDiv mode ArithException (WordN n) m - where - withBaseSafeDiv r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeDiv 'S ArithException (SymWordN n) m - where - withBaseSafeDiv r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeDiv - mode - (Either SomeBVException ArithException) - SomeIntN - m - where - withBaseSafeDiv r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeDiv - 'S - (Either SomeBVException ArithException) - SomeSymIntN - m - where - withBaseSafeDiv r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeDiv - mode - (Either SomeBVException ArithException) - SomeWordN - m - where - withBaseSafeDiv r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeDiv - 'S - (Either SomeBVException ArithException) - SomeSymWordN - m - where - withBaseSafeDiv r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeFdiv.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeFdiv.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeFdiv.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Eta reduce" #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeFdiv --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeFdiv - ( safeFdiv, - UnifiedSafeFdiv (..), - ) -where - -import Control.Exception (ArithException) -import Control.Monad.Error.Class (MonadError) -import Data.Typeable (Typeable) -import Grisette.Internal.Core.Data.Class.SafeFdiv (SafeFdiv) -import qualified Grisette.Internal.Core.Data.Class.SafeFdiv -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv` operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeFdiv @mode a b -safeFdiv :: - forall mode e a m. - (MonadError e m, UnifiedSafeFdiv mode e a m) => - a -> - a -> - m a -safeFdiv a b = - withBaseUnifiedSafeFdiv @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv a b -{-# INLINE safeFdiv #-} - --- | A class that provides unified floating division operations. --- --- We use this type class to help resolve the constraints for `SafeFdiv`. -class UnifiedSafeFdiv (mode :: EvalModeTag) e a m where - withBaseUnifiedSafeFdiv :: ((SafeFdiv e a m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeFdiv e a m) => - UnifiedSafeFdiv mode e a m - where - withBaseUnifiedSafeFdiv r = r - -instance - (Typeable mode, MonadError ArithException m, UnifiedBranching mode m) => - UnifiedSafeFdiv mode ArithException AlgReal m - where - withBaseUnifiedSafeFdiv r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m) => - UnifiedSafeFdiv 'S ArithException SymAlgReal m - where - withBaseUnifiedSafeFdiv r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeFromFP.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeFromFP.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeFromFP.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Eta reduce" #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeFromFP --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeFromFP - ( UnifiedSafeFromFP (..), - safeFromFP, - ) -where - -import Control.Monad.Error.Class (MonadError) -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SafeFromFP (SafeFromFP) -import qualified Grisette.Internal.Core.Data.Class.SafeFromFP as SafeFromFP -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - NotRepresentableFPError, - ValidFP, - ) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeFromFP.safeFromFP` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeFromFP @mode mode fp -safeFromFP :: - forall mode e a fp fprd m. - (UnifiedSafeFromFP mode e a fp fprd m, MonadError e m) => - fprd -> - fp -> - m a -safeFromFP rd fp = - withBaseSafeFromFP @mode @e @a @fp @fprd @m $ - SafeFromFP.safeFromFP rd fp - --- | A class that provides unified safe conversion from floating points. --- --- We use this type class to help resolve the constraints for `SafeFromFP`. -class UnifiedSafeFromFP (mode :: EvalModeTag) e a fp fprd m where - withBaseSafeFromFP :: ((SafeFromFP e a fp fprd m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeFromFP e a fp fprd m) => - UnifiedSafeFromFP mode e a fp fprd m - where - withBaseSafeFromFP r = r - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching mode m, - ValidFP eb sb - ) => - UnifiedSafeFromFP - mode - NotRepresentableFPError - Integer - (FP eb sb) - FPRoundingMode - m - where - withBaseSafeFromFP r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching mode m, - ValidFP eb sb - ) => - UnifiedSafeFromFP - mode - NotRepresentableFPError - AlgReal - (FP eb sb) - FPRoundingMode - m - where - withBaseSafeFromFP r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching mode m, - ValidFP eb sb, - KnownNat n, - 1 <= n - ) => - UnifiedSafeFromFP - mode - NotRepresentableFPError - (IntN n) - (FP eb sb) - FPRoundingMode - m - where - withBaseSafeFromFP r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching mode m, - ValidFP eb sb, - KnownNat n, - 1 <= n - ) => - UnifiedSafeFromFP - mode - NotRepresentableFPError - (WordN n) - (FP eb sb) - FPRoundingMode - m - where - withBaseSafeFromFP r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching 'S m, - ValidFP eb sb - ) => - UnifiedSafeFromFP - 'S - NotRepresentableFPError - SymInteger - (SymFP eb sb) - SymFPRoundingMode - m - where - withBaseSafeFromFP r = withBaseBranching @'S @m r - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching 'S m, - ValidFP eb sb - ) => - UnifiedSafeFromFP - 'S - NotRepresentableFPError - SymAlgReal - (SymFP eb sb) - SymFPRoundingMode - m - where - withBaseSafeFromFP r = withBaseBranching @'S @m r - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching 'S m, - ValidFP eb sb, - KnownNat n, - 1 <= n - ) => - UnifiedSafeFromFP - 'S - NotRepresentableFPError - (SymIntN n) - (SymFP eb sb) - SymFPRoundingMode - m - where - withBaseSafeFromFP r = withBaseBranching @'S @m r - -instance - ( MonadError NotRepresentableFPError m, - UnifiedBranching 'S m, - ValidFP eb sb, - KnownNat n, - 1 <= n - ) => - UnifiedSafeFromFP - 'S - NotRepresentableFPError - (SymWordN n) - (SymFP eb sb) - SymFPRoundingMode - m - where - withBaseSafeFromFP r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeLinearArith.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeLinearArith.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeLinearArith.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# HLINT ignore "Eta reduce" #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeLinearArith --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeLinearArith - ( safeAdd, - safeNeg, - safeSub, - UnifiedSafeLinearArith (..), - ) -where - -import Control.Monad.Error.Class (MonadError) -import Data.Typeable (Typeable) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SafeLinearArith - ( ArithException, - SafeLinearArith, - ) -import qualified Grisette.Internal.Core.Data.Class.SafeLinearArith -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.SomeBV - ( SomeBVException, - SomeIntN, - SomeSymIntN, - SomeSymWordN, - SomeWordN, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (S), - ) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeAdd` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeAdd @mode a b -safeAdd :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeLinearArith mode e a m - ) => - a -> - a -> - m a -safeAdd a b = - withBaseSafeLinearArith @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeLinearArith.safeAdd a b -{-# INLINE safeAdd #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeNeg` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeNeg @mode a -safeNeg :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeLinearArith mode e a m - ) => - a -> - m a -safeNeg a = - withBaseSafeLinearArith @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeLinearArith.safeNeg a -{-# INLINE safeNeg #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSub @mode a b -safeSub :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeLinearArith mode e a m - ) => - a -> - a -> - m a -safeSub a b = - withBaseSafeLinearArith @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub a b -{-# INLINE safeSub #-} - --- | A class that provides unified linear arithmetic operations. --- --- We use this type class to help resolve the constraints for `SafeLinearArith`. -class UnifiedSafeLinearArith (mode :: EvalModeTag) e a m where - withBaseSafeLinearArith :: ((SafeLinearArith e a m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeLinearArith e a m) => - UnifiedSafeLinearArith mode e a m - where - withBaseSafeLinearArith r = r - -instance - (Typeable mode, MonadError ArithException m, UnifiedBranching mode m) => - UnifiedSafeLinearArith mode ArithException Integer m - where - withBaseSafeLinearArith r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m) => - UnifiedSafeLinearArith 'S ArithException SymInteger m - where - withBaseSafeLinearArith r = withBaseBranching @'S @m r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeLinearArith mode ArithException (IntN n) m - where - withBaseSafeLinearArith r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeLinearArith 'S ArithException (SymIntN n) m - where - withBaseSafeLinearArith r = withBaseBranching @'S @m r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeLinearArith mode ArithException (WordN n) m - where - withBaseSafeLinearArith r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeLinearArith 'S ArithException (SymWordN n) m - where - withBaseSafeLinearArith r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeLinearArith - mode - (Either SomeBVException ArithException) - SomeIntN - m - where - withBaseSafeLinearArith r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeLinearArith - 'S - (Either SomeBVException ArithException) - SomeSymIntN - m - where - withBaseSafeLinearArith r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeLinearArith - mode - (Either SomeBVException ArithException) - SomeWordN - m - where - withBaseSafeLinearArith r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeLinearArith - 'S - (Either SomeBVException ArithException) - SomeSymWordN - m - where - withBaseSafeLinearArith r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeSymRotate.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeSymRotate.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeSymRotate.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# HLINT ignore "Eta reduce" #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeSymRotate --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeSymRotate - ( safeSymRotateL, - safeSymRotateR, - UnifiedSafeSymRotate (..), - ) -where - -import Control.Exception (ArithException) -import Control.Monad.Error.Class (MonadError) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate) -import qualified Grisette.Internal.Core.Data.Class.SafeSymRotate -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.SomeBV - ( SomeBVException, - SomeIntN, - SomeSymIntN, - SomeSymWordN, - SomeWordN, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (S), - ) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateL` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSymRotateL @mode a b -safeSymRotateL :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeSymRotate mode e a m - ) => - a -> - a -> - m a -safeSymRotateL a b = - withBaseSafeSymRotate @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateL a b -{-# INLINE safeSymRotateL #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateR` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSymRotateR @mode a b -safeSymRotateR :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeSymRotate mode e a m - ) => - a -> - a -> - m a -safeSymRotateR a b = - withBaseSafeSymRotate @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateR a b -{-# INLINE safeSymRotateR #-} - --- | A class that provides unified safe symbolic rotation operations. --- --- We use this type class to help resolve the constraints for `SafeSymRotate`. -class UnifiedSafeSymRotate (mode :: EvalModeTag) e a m where - withBaseSafeSymRotate :: ((SafeSymRotate e a m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeSymRotate e a m) => - UnifiedSafeSymRotate mode e a m - where - withBaseSafeSymRotate r = r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeSymRotate mode ArithException (IntN n) m - where - withBaseSafeSymRotate r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeSymRotate 'S ArithException (SymIntN n) m - where - withBaseSafeSymRotate r = withBaseBranching @'S @m r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeSymRotate mode ArithException (WordN n) m - where - withBaseSafeSymRotate r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeSymRotate 'S ArithException (SymWordN n) m - where - withBaseSafeSymRotate r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeSymRotate - mode - (Either SomeBVException ArithException) - SomeIntN - m - where - withBaseSafeSymRotate r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeSymRotate - 'S - (Either SomeBVException ArithException) - SomeSymIntN - m - where - withBaseSafeSymRotate r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeSymRotate - mode - (Either SomeBVException ArithException) - SomeWordN - m - where - withBaseSafeSymRotate r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeSymRotate - 'S - (Either SomeBVException ArithException) - SomeSymWordN - m - where - withBaseSafeSymRotate r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeSymShift.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeSymShift.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSafeSymShift.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# HLINT ignore "Eta reduce" #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSafeSymShift --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSafeSymShift - ( safeSymShiftL, - safeSymShiftR, - safeSymStrictShiftL, - safeSymStrictShiftR, - UnifiedSafeSymShift (..), - ) -where - -import Control.Exception (ArithException) -import Control.Monad.Error.Class (MonadError) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.SafeSymShift (SafeSymShift) -import qualified Grisette.Internal.Core.Data.Class.SafeSymShift -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.SomeBV - ( SomeBVException, - SomeIntN, - SomeSymIntN, - SomeSymWordN, - SomeWordN, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (S), - ) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftL` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSymShiftL @mode a b -safeSymShiftL :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeSymShift mode e a m - ) => - a -> - a -> - m a -safeSymShiftL a b = - withBaseSafeSymShift @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftL a b -{-# INLINE safeSymShiftL #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftR` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSymShiftR @mode a b -safeSymShiftR :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeSymShift mode e a m - ) => - a -> - a -> - m a -safeSymShiftR a b = - withBaseSafeSymShift @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftR a b -{-# INLINE safeSymShiftR #-} - --- | Unified --- `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftL` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSymStrictShiftL @mode a b -safeSymStrictShiftL :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeSymShift mode e a m - ) => - a -> - a -> - m a -safeSymStrictShiftL a b = - withBaseSafeSymShift @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftL a b -{-# INLINE safeSymStrictShiftL #-} - --- | Unified --- `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftR` --- operation. --- --- This function isn't able to infer the mode, so you need to provide the mode --- explicitly. For example: --- --- > safeSymStrictShiftR @mode a b -safeSymStrictShiftR :: - forall mode e a m. - ( MonadError e m, - UnifiedSafeSymShift mode e a m - ) => - a -> - a -> - m a -safeSymStrictShiftR a b = - withBaseSafeSymShift @mode @e @a @m $ - Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftR a b -{-# INLINE safeSymStrictShiftR #-} - --- | A class that provides unified safe symbolic rotation operations. --- --- We use this type class to help resolve the constraints for `SafeSymShift`. -class UnifiedSafeSymShift (mode :: EvalModeTag) e a m where - withBaseSafeSymShift :: ((SafeSymShift e a m) => r) -> r - -instance - {-# INCOHERENT #-} - (UnifiedBranching mode m, SafeSymShift e a m) => - UnifiedSafeSymShift mode e a m - where - withBaseSafeSymShift r = r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeSymShift mode ArithException (IntN n) m - where - withBaseSafeSymShift r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeSymShift 'S ArithException (SymIntN n) m - where - withBaseSafeSymShift r = withBaseBranching @'S @m r - -instance - (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => - UnifiedSafeSymShift mode ArithException (WordN n) m - where - withBaseSafeSymShift r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) => - UnifiedSafeSymShift 'S ArithException (SymWordN n) m - where - withBaseSafeSymShift r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeSymShift - mode - (Either SomeBVException ArithException) - SomeIntN - m - where - withBaseSafeSymShift r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeSymShift - 'S - (Either SomeBVException ArithException) - SomeSymIntN - m - where - withBaseSafeSymShift r = withBaseBranching @'S @m r - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching mode m - ) => - UnifiedSafeSymShift - mode - (Either SomeBVException ArithException) - SomeWordN - m - where - withBaseSafeSymShift r = - withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) - -instance - ( MonadError (Either SomeBVException ArithException) m, - UnifiedBranching 'S m - ) => - UnifiedSafeSymShift - 'S - (Either SomeBVException ArithException) - SomeSymWordN - m - where - withBaseSafeSymShift r = withBaseBranching @'S @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSimpleMergeable.hs b/src/Grisette/Unified/Internal/Class/UnifiedSimpleMergeable.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSimpleMergeable.hs +++ /dev/null @@ -1,809 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSimpleMergeable --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (..), - UnifiedSimpleMergeable (..), - UnifiedSimpleMergeable1 (..), - UnifiedSimpleMergeable2 (..), - mrgIf, - liftBaseMonad, - mrgIte, - mrgIte1, - liftMrgIte, - mrgIte2, - liftMrgIte2, - simpleMerge, - ) -where - -import Control.Monad.Cont (ContT) -import Control.Monad.Except (ExceptT) -import Control.Monad.Identity (Identity (runIdentity), IdentityT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Trans.RWS.Lazy as RWSLazy -import qualified Control.Monad.Trans.RWS.Strict as RWSStrict -import Control.Monad.Trans.Reader (ReaderT) -import qualified Control.Monad.Trans.State.Lazy as StateLazy -import qualified Control.Monad.Trans.State.Strict as StateStrict -import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy -import qualified Control.Monad.Trans.Writer.Strict as WriterStrict -import Data.Kind (Constraint) -import Data.Type.Bool (If) -import Data.Typeable (Typeable) -import Grisette.Internal.Core.Control.Exception (AssertionError) -import Grisette.Internal.Core.Control.Monad.Union (liftUnion) -import Grisette.Internal.Core.Data.Class.GenSym (FreshT) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import qualified Grisette.Internal.Core.Data.Class.PlainUnion as Grisette -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SimpleMergeable, - SimpleMergeable1, - SimpleMergeable2, - SymBranching, - ) -import qualified Grisette.Internal.Core.Data.Class.SimpleMergeable -import qualified Grisette.Internal.Core.Data.Class.SimpleMergeable as Grisette -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge, - mrgSingle, - ) -import Grisette.Internal.TH.DeriveUnifiedInterface - ( deriveFunctorArgUnifiedInterfaces, - deriveUnifiedInterface1s, - ) -import Grisette.Unified.Internal.BaseMonad (BaseMonad) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag, - IsConMode, - ) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `Grisette.mrgIf`. --- --- This function isn't able to infer the mode of the boolean variable, so you --- need to provide the mode explicitly. For example: --- --- > mrgIf @mode (a .== b) ... --- > mrgIf (a .== b :: SymBool) ... --- > mrgIf (a .== b :: GetBool mode) ... -mrgIf :: - forall mode a m. - (Typeable mode, Mergeable a, UnifiedBranching mode m) => - GetBool mode -> - m a -> - m a -> - m a -mrgIf c t e = - withMode @mode - (if c then t else e) - (withBaseBranching @mode @m $ Grisette.mrgIf c t e) -{-# INLINE mrgIf #-} - --- | Unified lifting of a base monad. -liftBaseMonad :: - forall mode a m. - ( Applicative m, - UnifiedBranching mode m, - Mergeable a - ) => - BaseMonad mode a -> - m a -liftBaseMonad b = - withMode @mode - (withBaseBranching @mode @m $ mrgSingle . runIdentity $ b) - (withBaseBranching @mode @m $ liftUnion b) -{-# INLINE liftBaseMonad #-} - --- | Unified merge of simply mergeable values in the base monad. -simpleMerge :: - forall mode a. - (Typeable mode, UnifiedSimpleMergeable mode a) => - BaseMonad mode a -> - a -simpleMerge = - withMode @mode - runIdentity - (withBaseSimpleMergeable @mode @a Grisette.simpleMerge) - --- | Unified `Grisette.mrgIte`. -mrgIte :: - forall mode a. - (Typeable mode, UnifiedSimpleMergeable mode a) => - GetBool mode -> - a -> - a -> - a -mrgIte c t e = - withMode @mode - (if c then t else e) - ( withBaseSimpleMergeable @mode @a $ - Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte c t e - ) - --- | Unified `Grisette.mrgIte1`. -mrgIte1 :: - forall mode f a. - ( Typeable mode, - UnifiedSimpleMergeable1 mode f, - UnifiedSimpleMergeable mode a - ) => - GetBool mode -> - f a -> - f a -> - f a -mrgIte1 c t e = - withMode @mode - (if c then t else e) - ( withBaseSimpleMergeable @mode @a $ - withBaseSimpleMergeable1 @mode @f $ - Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte1 c t e - ) - --- | Unified `Grisette.liftMrgIte`. -liftMrgIte :: - forall mode f a. - ( Typeable mode, - UnifiedSimpleMergeable1 mode f - ) => - (GetBool mode -> a -> a -> a) -> - GetBool mode -> - f a -> - f a -> - f a -liftMrgIte f c t e = - withMode @mode - (if c then t else e) - ( withBaseSimpleMergeable1 @mode @f $ - Grisette.Internal.Core.Data.Class.SimpleMergeable.liftMrgIte f c t e - ) - --- | Unified `Grisette.mrgIte2`. -mrgIte2 :: - forall mode f a b. - ( Typeable mode, - UnifiedSimpleMergeable2 mode f, - UnifiedSimpleMergeable mode a, - UnifiedSimpleMergeable mode b - ) => - GetBool mode -> - f a b -> - f a b -> - f a b -mrgIte2 c t e = - withMode @mode - (if c then t else e) - ( withBaseSimpleMergeable @mode @a $ - withBaseSimpleMergeable @mode @b $ - withBaseSimpleMergeable2 @mode @f $ - Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte2 c t e - ) - --- | Unified `Grisette.liftMrgIte2`. -liftMrgIte2 :: - forall mode f a b. - ( Typeable mode, - UnifiedSimpleMergeable2 mode f - ) => - (GetBool mode -> a -> a -> a) -> - (GetBool mode -> b -> b -> b) -> - GetBool mode -> - f a b -> - f a b -> - f a b -liftMrgIte2 f g c t e = - withMode @mode - (if c then t else e) - ( withBaseSimpleMergeable2 @mode @f $ - Grisette.Internal.Core.Data.Class.SimpleMergeable.liftMrgIte2 f g c t e - ) - --- | A class that provides a unified simple merging. --- --- We use this type class to help resolve the constraints for `SimpleMergeable`. -class UnifiedSimpleMergeable mode a where - withBaseSimpleMergeable :: - ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable a)) => r) -> r - --- | A class that provides lifting of unified simple merging. --- --- We use this type class to help resolve the constraints for --- `SimpleMergeable1`. -class UnifiedSimpleMergeable1 mode f where - withBaseSimpleMergeable1 :: - ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 f)) => r) -> r - --- | A class that provides lifting of unified simple merging. --- --- We use this type class to help resolve the constraints for --- `SimpleMergeable2`. -class UnifiedSimpleMergeable2 mode f where - withBaseSimpleMergeable2 :: - ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 f)) => r) -> r - --- | A class that provides a unified branching operation. --- --- We use this type class to help resolve the constraints for --- `SymBranching`. -class - (Typeable mode) => - UnifiedBranching (mode :: EvalModeTag) m - where - withBaseBranching :: - ((If (IsConMode mode) (TryMerge m) (SymBranching m)) => r) -> r - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) ((TryMerge m) :: Constraint) (SymBranching m) - ) => - UnifiedBranching mode m - where - withBaseBranching r = r - {-# INLINE withBaseBranching #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (() :: Constraint) (SimpleMergeable m) - ) => - UnifiedSimpleMergeable mode m - where - withBaseSimpleMergeable r = r - {-# INLINE withBaseSimpleMergeable #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 m) - ) => - UnifiedSimpleMergeable1 mode m - where - withBaseSimpleMergeable1 r = r - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 m) - ) => - UnifiedSimpleMergeable2 mode m - where - withBaseSimpleMergeable2 r = r - {-# INLINE withBaseSimpleMergeable2 #-} - -deriveFunctorArgUnifiedInterfaces - ''UnifiedSimpleMergeable - 'withBaseSimpleMergeable - ''UnifiedSimpleMergeable1 - 'withBaseSimpleMergeable1 - [ ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''Identity - ] - -deriveUnifiedInterface1s - ''UnifiedSimpleMergeable - 'withBaseSimpleMergeable - ''UnifiedSimpleMergeable1 - 'withBaseSimpleMergeable1 - [ ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''Identity - ] - -instance (Typeable mode) => UnifiedSimpleMergeable2 mode (,) where - withBaseSimpleMergeable2 r = withMode @mode r r - {-# INLINE withBaseSimpleMergeable2 #-} - -instance - (Typeable mode, UnifiedSimpleMergeable mode a) => - UnifiedSimpleMergeable2 mode ((,,) a) - where - withBaseSimpleMergeable2 r = - withMode @mode - (withBaseSimpleMergeable @mode @a r) - (withBaseSimpleMergeable @mode @a r) - {-# INLINE withBaseSimpleMergeable2 #-} - -instance - ( Typeable mode, - UnifiedSimpleMergeable mode a, - UnifiedSimpleMergeable mode b - ) => - UnifiedSimpleMergeable2 mode ((,,,) a b) - where - withBaseSimpleMergeable2 r = - withMode @mode - (withBaseSimpleMergeable @mode @a $ withBaseSimpleMergeable @mode @b r) - (withBaseSimpleMergeable @mode @a $ withBaseSimpleMergeable @mode @b r) - {-# INLINE withBaseSimpleMergeable2 #-} - -instance - (Typeable mode, UnifiedSimpleMergeable mode b) => - UnifiedSimpleMergeable mode (a -> b) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseSimpleMergeable @mode @b r) - (withBaseSimpleMergeable @mode @b r) - {-# INLINE withBaseSimpleMergeable #-} - -instance (Typeable mode) => UnifiedSimpleMergeable1 mode ((->) a) where - withBaseSimpleMergeable1 r = withMode @mode r r - {-# INLINE withBaseSimpleMergeable1 #-} - -instance (Typeable mode) => UnifiedSimpleMergeable2 mode (->) where - withBaseSimpleMergeable2 r = withMode @mode r r - {-# INLINE withBaseSimpleMergeable2 #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable a) => - UnifiedSimpleMergeable mode (FreshT m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedSimpleMergeable1 mode (FreshT m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedBranching mode (FreshT m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable a) => - UnifiedSimpleMergeable mode (MaybeT m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedSimpleMergeable1 mode (MaybeT m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedBranching mode (MaybeT m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable a) => - UnifiedSimpleMergeable mode (IdentityT m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedSimpleMergeable1 mode (IdentityT m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedBranching mode (IdentityT m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable a) => - UnifiedSimpleMergeable mode (ReaderT r m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedSimpleMergeable1 mode (ReaderT r m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - (Typeable mode, UnifiedBranching mode m) => - UnifiedBranching mode (ReaderT r m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable s, Mergeable a) => - UnifiedSimpleMergeable mode (StateLazy.StateT s m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable s) => - UnifiedSimpleMergeable1 mode (StateLazy.StateT s m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable s - ) => - UnifiedBranching mode (StateLazy.StateT s m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable s, Mergeable a) => - UnifiedSimpleMergeable mode (StateStrict.StateT s m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable s) => - UnifiedSimpleMergeable1 mode (StateStrict.StateT s m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable s - ) => - UnifiedBranching mode (StateStrict.StateT s m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable w, - Mergeable a, - Monoid w - ) => - UnifiedSimpleMergeable mode (WriterLazy.WriterT w m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable w, Monoid w) => - UnifiedSimpleMergeable1 mode (WriterLazy.WriterT w m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Monoid w, - Mergeable w - ) => - UnifiedBranching mode (WriterLazy.WriterT w m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable w, - Mergeable a, - Monoid w - ) => - UnifiedSimpleMergeable mode (WriterStrict.WriterT w m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable w, Monoid w) => - UnifiedSimpleMergeable1 mode (WriterStrict.WriterT w m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Monoid w, - Mergeable w - ) => - UnifiedBranching mode (WriterStrict.WriterT w m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable e, - Mergeable a - ) => - UnifiedSimpleMergeable mode (ExceptT e m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable e) => - UnifiedSimpleMergeable1 mode (ExceptT e m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - (Typeable mode, Mergeable e, UnifiedBranching mode m) => - UnifiedBranching mode (ExceptT e m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable r, - Mergeable a - ) => - UnifiedSimpleMergeable mode (ContT r m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - (Typeable mode, UnifiedBranching mode m, Mergeable r) => - UnifiedSimpleMergeable1 mode (ContT r m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - (Typeable mode, Mergeable r, UnifiedBranching mode m) => - UnifiedBranching mode (ContT r m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable w, - Monoid w, - Mergeable s, - Mergeable a - ) => - UnifiedSimpleMergeable mode (RWSLazy.RWST r w s m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable w, - Monoid w, - Mergeable s - ) => - UnifiedSimpleMergeable1 mode (RWSLazy.RWST r w s m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable s, - Monoid w, - Mergeable w - ) => - UnifiedBranching mode (RWSLazy.RWST r w s m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable w, - Monoid w, - Mergeable s, - Mergeable a - ) => - UnifiedSimpleMergeable mode (RWSStrict.RWST r w s m a) - where - withBaseSimpleMergeable r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable w, - Monoid w, - Mergeable s - ) => - UnifiedSimpleMergeable1 mode (RWSStrict.RWST r w s m) - where - withBaseSimpleMergeable1 r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseSimpleMergeable1 #-} - -instance - ( Typeable mode, - UnifiedBranching mode m, - Mergeable s, - Monoid w, - Mergeable w - ) => - UnifiedBranching mode (RWSStrict.RWST r w s m) - where - withBaseBranching r = - withMode @mode - (withBaseBranching @mode @m r) - (withBaseBranching @mode @m r) - {-# INLINE withBaseBranching #-} diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSolvable.hs b/src/Grisette/Unified/Internal/Class/UnifiedSolvable.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSolvable.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSolvable --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSolvable - ( UnifiedSolvable (withBaseSolvable), - con, - pattern Con, - conView, - ) -where - -import Data.Type.Bool (If) -import Data.Typeable (Typeable) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable) -import qualified Grisette.Internal.Core.Data.Class.Solvable as Grisette -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, ValidFP) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S), IsConMode) -import Grisette.Unified.Internal.Util (withMode) - --- $setup --- >>> import Grisette.Core (ssym) - --- | Wrap a concrete value in a symbolic value. --- --- >>> con True :: Bool --- True --- --- >>> con True :: SymBool --- true -con :: - forall mode a con. (Typeable mode, UnifiedSolvable mode a con) => con -> a -con v = - withMode @mode - (withBaseSolvable @mode @a @con v) - (withBaseSolvable @mode @a @con $ Grisette.con v) - --- | Extract the concrete value from a symbolic value. --- --- >>> conView (con True :: SymBool) --- Just True --- --- >>> conView (ssym "a" :: SymBool) --- Nothing --- --- >>> conView True --- Just True -conView :: - forall mode a con. - (Typeable mode, UnifiedSolvable mode a con) => - a -> - Maybe con -conView v = - withMode @mode - (withBaseSolvable @mode @a @con $ Just v) - (withBaseSolvable @mode @a @con $ Grisette.conView v) - --- | A pattern synonym for extracting the concrete value from a symbolic value. --- --- >>> case con True :: SymBool of Con v -> v --- True --- --- >>> case ssym "a" :: SymBool of Con v -> Just v; _ -> Nothing --- Nothing -pattern Con :: (Typeable mode, UnifiedSolvable mode a con) => con -> a -pattern Con v <- - (conView -> Just v) - where - Con v = con v - --- | A class that provides the ability to extract/wrap the concrete value --- from/into a symbolic value. -class UnifiedSolvable mode a con | a -> mode con, con mode -> a where - withBaseSolvable :: - ((If (IsConMode mode) (a ~ con) (Solvable con a)) => r) -> r - -instance UnifiedSolvable 'C Bool Bool where - withBaseSolvable r = r - -instance UnifiedSolvable 'S SymBool Bool where - withBaseSolvable r = r - -instance UnifiedSolvable 'C Integer Integer where - withBaseSolvable r = r - -instance UnifiedSolvable 'S SymInteger Integer where - withBaseSolvable r = r - -instance UnifiedSolvable 'C AlgReal AlgReal where - withBaseSolvable r = r - -instance UnifiedSolvable 'S SymAlgReal AlgReal where - withBaseSolvable r = r - -instance (KnownNat n, 1 <= n) => UnifiedSolvable 'C (WordN n) (WordN n) where - withBaseSolvable r = r - -instance (KnownNat n, 1 <= n) => UnifiedSolvable 'S (SymWordN n) (WordN n) where - withBaseSolvable r = r - -instance (KnownNat n, 1 <= n) => UnifiedSolvable 'C (IntN n) (IntN n) where - withBaseSolvable r = r - -instance (KnownNat n, 1 <= n) => UnifiedSolvable 'S (SymIntN n) (IntN n) where - withBaseSolvable r = r - -instance (ValidFP eb sb) => UnifiedSolvable 'C (FP eb sb) (FP eb sb) where - withBaseSolvable r = r - -instance (ValidFP eb sb) => UnifiedSolvable 'S (SymFP eb sb) (FP eb sb) where - withBaseSolvable r = r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs b/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs +++ /dev/null @@ -1,416 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Eta reduce" #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSymEq --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSymEq - ( UnifiedSymEq (..), - UnifiedSymEq1 (..), - UnifiedSymEq2 (..), - (.==), - (./=), - symDistinct, - liftSymEq, - symEq1, - liftSymEq2, - symEq2, - ) -where - -import Control.Monad.Except (ExceptT) -import Control.Monad.Identity (Identity, IdentityT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2), eq1, eq2) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Ratio (Ratio) -import qualified Data.Text as T -import Data.Type.Bool (If) -import Data.Typeable (Typeable) -import Data.Word (Word16, Word32, Word64, Word8) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Control.Monad.Union (Union) -import Grisette.Internal.Core.Data.Class.SymEq (SymEq, SymEq1, SymEq2) -import qualified Grisette.Internal.Core.Data.Class.SymEq -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.TH.DeriveUnifiedInterface - ( deriveFunctorArgUnifiedInterfaces, - deriveUnifiedInterface1s, - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S), IsConMode) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `(Grisette.Internal.Core.Data.Class.SymEq..==)`. --- --- Note that you may sometimes need to write type annotations for the result --- when the mode isn't clear: --- --- > a .== b :: GetBool mode --- --- One example when it isn't clear is when this is used in unified --- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. -(.==) :: - forall mode a. (Typeable mode, UnifiedSymEq mode a) => a -> a -> GetBool mode -(.==) a b = - withMode @mode - (withBaseSymEq @mode @a $ a == b) - (withBaseSymEq @mode @a $ a Grisette.Internal.Core.Data.Class.SymEq..== b) - --- | Unified `(Grisette.Internal.Core.Data.Class.SymEq../=)`. --- --- Note that you may sometimes need to write type annotations for the result --- when the mode isn't clear: --- --- > a ./= b :: GetBool mode --- --- One example when it isn't clear is when this is used in unified --- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. -(./=) :: - forall mode a. (Typeable mode, UnifiedSymEq mode a) => a -> a -> GetBool mode -(./=) a b = - withMode @mode - (withBaseSymEq @mode @a $ a /= b) - (withBaseSymEq @mode @a $ a Grisette.Internal.Core.Data.Class.SymEq../= b) - --- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symDistinct`. --- --- Note that you may sometimes need to write type annotations for the result --- when the mode isn't clear: --- --- > symDistinct l :: GetBool mode --- --- One example when it isn't clear is when this is used in unified --- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. -symDistinct :: - forall mode a. (Typeable mode, UnifiedSymEq mode a) => [a] -> GetBool mode -symDistinct l = - withMode @mode - ( withBaseSymEq @mode @a $ - Grisette.Internal.Core.Data.Class.SymEq.distinct l - ) - ( withBaseSymEq @mode @a $ - Grisette.Internal.Core.Data.Class.SymEq.symDistinct l - ) - --- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq`. -liftSymEq :: - forall mode f a b. - (Typeable mode, UnifiedSymEq1 mode f) => - (a -> b -> GetBool mode) -> - f a -> - f b -> - GetBool mode -liftSymEq f a b = - withMode @mode - (withBaseSymEq1 @mode @f $ liftEq f a b) - ( withBaseSymEq1 @mode @f $ - Grisette.Internal.Core.Data.Class.SymEq.liftSymEq f a b - ) - --- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq1`. -symEq1 :: - forall mode f a. - (Typeable mode, UnifiedSymEq mode a, UnifiedSymEq1 mode f) => - f a -> - f a -> - GetBool mode -symEq1 a b = - withMode @mode - (withBaseSymEq1 @mode @f $ withBaseSymEq @mode @a eq1 a b) - ( withBaseSymEq1 @mode @f $ - withBaseSymEq @mode @a $ - Grisette.Internal.Core.Data.Class.SymEq.symEq1 a b - ) - --- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq2`. -liftSymEq2 :: - forall mode f a b c d. - (Typeable mode, UnifiedSymEq2 mode f) => - (a -> b -> GetBool mode) -> - (c -> d -> GetBool mode) -> - f a c -> - f b d -> - GetBool mode -liftSymEq2 f a b = - withMode @mode - (withBaseSymEq2 @mode @f $ liftEq2 f a b) - ( withBaseSymEq2 @mode @f $ - Grisette.Internal.Core.Data.Class.SymEq.liftSymEq2 f a b - ) - --- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq2`. -symEq2 :: - forall mode f a b. - ( Typeable mode, - UnifiedSymEq mode a, - UnifiedSymEq mode b, - UnifiedSymEq2 mode f - ) => - f a b -> - f a b -> - GetBool mode -symEq2 a b = - withMode @mode - ( withBaseSymEq2 @mode @f $ - withBaseSymEq @mode @a $ - withBaseSymEq @mode @b eq2 a b - ) - ( withBaseSymEq2 @mode @f $ - withBaseSymEq @mode @a $ - withBaseSymEq @mode @b $ - Grisette.Internal.Core.Data.Class.SymEq.symEq2 a b - ) - --- | A class that provides unified equality comparison. --- --- We use this type class to help resolve the constraints for `Eq` and `SymEq`. -class UnifiedSymEq mode a where - withBaseSymEq :: ((If (IsConMode mode) (Eq a) (SymEq a)) => r) -> r - --- | A class that provides unified lifting of equality comparison. --- --- We use this type class to help resolve the constraints for `Eq1` and --- `SymEq1`. -class - (forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a)) => - UnifiedSymEq1 mode f - where - withBaseSymEq1 :: ((If (IsConMode mode) (Eq1 f) (SymEq1 f)) => r) -> r - --- | A class that provides unified lifting of equality comparison. --- --- We use this type class to help resolve the constraints for `Eq2` and --- `SymEq2`. -class - (forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a)) => - UnifiedSymEq2 mode f - where - withBaseSymEq2 :: ((If (IsConMode mode) (Eq2 f) (SymEq2 f)) => r) -> r - -instance - {-# INCOHERENT #-} - (Typeable mode, If (IsConMode mode) (Eq a) (SymEq a)) => - UnifiedSymEq mode a - where - withBaseSymEq r = r - {-# INLINE withBaseSymEq #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (Eq1 f) (SymEq1 f), - forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a) - ) => - UnifiedSymEq1 mode f - where - withBaseSymEq1 r = r - {-# INLINE withBaseSymEq1 #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (Eq2 f) (SymEq2 f), - forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a) - ) => - UnifiedSymEq2 mode f - where - withBaseSymEq2 r = r - {-# INLINE withBaseSymEq2 #-} - -instance (UnifiedSymEq 'S v) => UnifiedSymEq 'S (Union v) where - withBaseSymEq r = withBaseSymEq @'S @v r - {-# INLINE withBaseSymEq #-} - -instance - (Typeable mode, UnifiedSymEq mode a) => - UnifiedSymEq mode (Ratio a) - where - withBaseSymEq r = - withMode @mode (withBaseSymEq @mode @a r) (withBaseSymEq @mode @a r) - {-# INLINE withBaseSymEq #-} - -deriveFunctorArgUnifiedInterfaces - ''UnifiedSymEq - 'withBaseSymEq - ''UnifiedSymEq1 - 'withBaseSymEq1 - [ ''Bool, - ''Integer, - ''Char, - ''Int, - ''Int8, - ''Int16, - ''Int32, - ''Int64, - ''Word, - ''Word8, - ''Word16, - ''Word32, - ''Word64, - ''Float, - ''Double, - ''B.ByteString, - ''T.Text, - ''FPRoundingMode, - ''WordN, - ''IntN, - ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''ExceptT, - ''MaybeT, - ''WriterLazy.WriterT, - ''WriterStrict.WriterT, - ''Identity - ] - -deriveUnifiedInterface1s - ''UnifiedSymEq - 'withBaseSymEq - ''UnifiedSymEq1 - 'withBaseSymEq1 - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''ExceptT, - ''MaybeT, - ''WriterLazy.WriterT, - ''WriterStrict.WriterT, - ''Identity - ] - --- Sum -instance - ( Typeable mode, - UnifiedSymEq1 mode f, - UnifiedSymEq1 mode g, - UnifiedSymEq mode a - ) => - UnifiedSymEq mode (Sum f g a) - where - withBaseSymEq r = - withMode @mode - ( withBaseSymEq1 @mode @f $ - withBaseSymEq1 @mode @g $ - withBaseSymEq @mode @a r - ) - ( withBaseSymEq1 @mode @f $ - withBaseSymEq1 @mode @g $ - withBaseSymEq @mode @a r - ) - {-# INLINE withBaseSymEq #-} - -instance - (Typeable mode, UnifiedSymEq1 mode f, UnifiedSymEq1 mode g) => - UnifiedSymEq1 mode (Sum f g) - where - withBaseSymEq1 r = - withMode @mode - (withBaseSymEq1 @mode @f $ withBaseSymEq1 @mode @g r) - (withBaseSymEq1 @mode @f $ withBaseSymEq1 @mode @g r) - {-# INLINE withBaseSymEq1 #-} - --- IdentityT -instance - (Typeable mode, UnifiedSymEq1 mode m, UnifiedSymEq mode a) => - UnifiedSymEq mode (IdentityT m a) - where - withBaseSymEq r = - withMode @mode - (withBaseSymEq1 @mode @m $ withBaseSymEq @mode @a r) - (withBaseSymEq1 @mode @m $ withBaseSymEq @mode @a r) - {-# INLINE withBaseSymEq #-} - -instance - (Typeable mode, UnifiedSymEq1 mode m) => - UnifiedSymEq1 mode (IdentityT m) - where - withBaseSymEq1 r = - withMode @mode (withBaseSymEq1 @mode @m r) (withBaseSymEq1 @mode @m r) - {-# INLINE withBaseSymEq1 #-} - -instance (Typeable mode, ValidFP eb sb) => UnifiedSymEq mode (FP eb sb) where - withBaseSymEq r = withMode @mode r r - {-# INLINE withBaseSymEq #-} - -instance (Typeable mode) => UnifiedSymEq2 mode Either where - withBaseSymEq2 r = withMode @mode r r - {-# INLINE withBaseSymEq2 #-} - -instance (Typeable mode) => UnifiedSymEq2 mode (,) where - withBaseSymEq2 r = withMode @mode r r - {-# INLINE withBaseSymEq2 #-} - -#if MIN_VERSION_base(4,16,0) -deriveUnifiedInterface1s - ''UnifiedSymEq - 'withBaseSymEq - ''UnifiedSymEq1 - 'withBaseSymEq1 - [ ''(,,), - ''(,,,) - ] - -instance (Typeable mode, UnifiedSymEq mode a) => - UnifiedSymEq2 mode ((,,) a) where - withBaseSymEq2 r = - withMode @mode (withBaseSymEq @mode @a r) (withBaseSymEq @mode @a r) - {-# INLINE withBaseSymEq2 #-} - -instance - (Typeable mode, UnifiedSymEq mode a, UnifiedSymEq mode b) => - UnifiedSymEq2 mode ((,,,) a b) - where - withBaseSymEq2 r = - withMode @mode - (withBaseSymEq @mode @a $ withBaseSymEq @mode @b r) - (withBaseSymEq @mode @a $ withBaseSymEq @mode @b r) - {-# INLINE withBaseSymEq2 #-} -#endif diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs b/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs +++ /dev/null @@ -1,545 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Eta reduce" #-} - --- | --- Module : Grisette.Unified.Internal.Class.UnifiedSymOrd --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Class.UnifiedSymOrd - ( UnifiedSymOrd (..), - UnifiedSymOrd1 (..), - UnifiedSymOrd2 (..), - (.<=), - (.<), - (.>=), - (.>), - symCompare, - liftSymCompare, - symCompare1, - liftSymCompare2, - symCompare2, - symMax, - symMin, - mrgMax, - mrgMin, - ) -where - -import Control.Monad.Except (ExceptT) -import Control.Monad.Identity (Identity (runIdentity), IdentityT) -import Control.Monad.Trans.Maybe (MaybeT) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Classes - ( Ord1 (liftCompare), - Ord2 (liftCompare2), - compare1, - compare2, - ) -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Ratio (Ratio) -import qualified Data.Text as T -import Data.Type.Bool (If) -import Data.Typeable (Typeable) -import Data.Word (Word16, Word32, Word64, Word8) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Control.Monad.Union (Union) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd, SymOrd1, SymOrd2) -import qualified Grisette.Internal.Core.Data.Class.SymOrd -import Grisette.Internal.Core.Data.Class.TryMerge (tryMerge) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.TH.DeriveUnifiedInterface - ( deriveFunctorArgUnifiedInterfaces, - deriveUnifiedInterface1s, - ) -import Grisette.Unified.Internal.BaseMonad (BaseMonad) -import Grisette.Unified.Internal.Class.UnifiedITEOp - ( UnifiedITEOp (withBaseITEOp), - ) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - ) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (S), - IsConMode, - ) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.Util (withMode) - --- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<=)`. --- --- Note that you may sometimes need to write type annotations for the result --- when the mode isn't clear: --- --- > a .<= b :: GetBool mode --- --- One example when it isn't clear is when this is used in unified --- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. -(.<=) :: - forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode -(.<=) a b = - withMode @mode - (withBaseSymOrd @mode @a $ a <= b) - (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..<= b) -{-# INLINE (.<=) #-} - --- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<)`. -(.<) :: - forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode -(.<) a b = - withMode @mode - (withBaseSymOrd @mode @a $ a < b) - (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..< b) -{-# INLINE (.<) #-} - --- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>=)`. -(.>=) :: - forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode -(.>=) a b = - withMode @mode - (withBaseSymOrd @mode @a $ a >= b) - (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..>= b) -{-# INLINE (.>=) #-} - --- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>)`. -(.>) :: - forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode -(.>) a b = - withMode @mode - (withBaseSymOrd @mode @a $ a > b) - (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..> b) -{-# INLINE (.>) #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare`. -symCompare :: - forall mode a ctx. - (Typeable mode, UnifiedSymOrd mode a, Monad ctx) => - a -> - a -> - BaseMonad mode Ordering -symCompare x y = - withMode @mode - (withBaseSymOrd @mode @a $ return $ compare x y) - ( withBaseSymOrd @mode @a $ - Grisette.Internal.Core.Data.Class.SymOrd.symCompare x y - ) -{-# INLINE symCompare #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare`. -liftSymCompare :: - forall mode f a b. - (Typeable mode, UnifiedSymOrd1 mode f) => - (a -> b -> BaseMonad mode Ordering) -> - f a -> - f b -> - BaseMonad mode Ordering -liftSymCompare f a b = - withMode @mode - ( withBaseSymOrd1 @mode @f $ - return $ - liftCompare (\x y -> runIdentity $ f x y) a b - ) - ( withBaseSymOrd1 @mode @f $ - Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare f a b - ) -{-# INLINE liftSymCompare #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare1`. -symCompare1 :: - forall mode f a. - (Typeable mode, UnifiedSymOrd mode a, UnifiedSymOrd1 mode f) => - f a -> - f a -> - BaseMonad mode Ordering -symCompare1 a b = - withMode @mode - (withBaseSymOrd1 @mode @f $ withBaseSymOrd @mode @a $ return $ compare1 a b) - ( withBaseSymOrd1 @mode @f $ - withBaseSymOrd @mode @a $ - Grisette.Internal.Core.Data.Class.SymOrd.symCompare1 a b - ) -{-# INLINE symCompare1 #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare2`. -liftSymCompare2 :: - forall mode f a b c d. - (Typeable mode, UnifiedSymOrd2 mode f) => - (a -> b -> BaseMonad mode Ordering) -> - (c -> d -> BaseMonad mode Ordering) -> - f a c -> - f b d -> - BaseMonad mode Ordering -liftSymCompare2 f g a b = - withMode @mode - ( withBaseSymOrd2 @mode @f $ - return $ - liftCompare2 - (\x y -> runIdentity $ f x y) - (\x y -> runIdentity $ g x y) - a - b - ) - ( withBaseSymOrd2 @mode @f $ - Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare2 f g a b - ) -{-# INLINE liftSymCompare2 #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare2`. -symCompare2 :: - forall mode f a b. - ( Typeable mode, - UnifiedSymOrd mode a, - UnifiedSymOrd mode b, - UnifiedSymOrd2 mode f - ) => - f a b -> - f a b -> - BaseMonad mode Ordering -symCompare2 a b = - withMode @mode - ( withBaseSymOrd2 @mode @f $ - withBaseSymOrd @mode @a $ - withBaseSymOrd @mode @b $ - return $ - compare2 a b - ) - ( withBaseSymOrd2 @mode @f $ - withBaseSymOrd @mode @a $ - withBaseSymOrd @mode @b $ - Grisette.Internal.Core.Data.Class.SymOrd.symCompare2 a b - ) -{-# INLINE symCompare2 #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMax`. -symMax :: - forall mode a. - (UnifiedSymOrd mode a, UnifiedITEOp mode a, Typeable mode) => - a -> - a -> - a -symMax x y = - withMode @mode - (withBaseSymOrd @mode @a $ max x y) - ( withBaseSymOrd @mode @a $ - withBaseITEOp @mode @a - Grisette.Internal.Core.Data.Class.SymOrd.symMax - x - y - ) -{-# INLINE symMax #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMin`. -symMin :: - forall mode a. - (UnifiedSymOrd mode a, UnifiedITEOp mode a, Typeable mode) => - a -> - a -> - a -symMin x y = - withMode @mode - (withBaseSymOrd @mode @a $ min x y) - ( withBaseSymOrd @mode @a $ - withBaseITEOp @mode @a - Grisette.Internal.Core.Data.Class.SymOrd.symMin - x - y - ) -{-# INLINE symMin #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.mrgMax`. -mrgMax :: - forall mode a m. - ( UnifiedSymOrd mode a, - UnifiedBranching mode m, - Typeable mode, - Applicative m, - Mergeable a - ) => - a -> - a -> - m a -mrgMax x y = - withMode @mode - ( withBaseSymOrd @mode @a $ - withBaseBranching @mode @m $ - tryMerge $ - pure $ - max x y - ) - ( withBaseSymOrd @mode @a $ - withBaseBranching @mode @m $ - Grisette.Internal.Core.Data.Class.SymOrd.mrgMax x y - ) -{-# INLINE mrgMax #-} - --- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.mrgMin`. -mrgMin :: - forall mode a m. - ( UnifiedSymOrd mode a, - UnifiedBranching mode m, - Typeable mode, - Applicative m, - Mergeable a - ) => - a -> - a -> - m a -mrgMin x y = - withMode @mode - ( withBaseSymOrd @mode @a $ - withBaseBranching @mode @m $ - tryMerge $ - pure $ - min x y - ) - ( withBaseSymOrd @mode @a $ - withBaseBranching @mode @m $ - Grisette.Internal.Core.Data.Class.SymOrd.mrgMin x y - ) -{-# INLINE mrgMin #-} - --- | A class that provides unified comparison. --- --- We use this type class to help resolve the constraints for `Ord` and --- `SymOrd`. -class UnifiedSymOrd mode a where - withBaseSymOrd :: (((If (IsConMode mode) (Ord a) (SymOrd a)) => r)) -> r - --- | A class that provides unified lifting of comparison. --- --- We use this type class to help resolve the constraints for `Ord1` and --- `SymOrd1`. -class UnifiedSymOrd1 mode f where - withBaseSymOrd1 :: (((If (IsConMode mode) (Ord1 f) (SymOrd1 f)) => r)) -> r - --- | A class that provides unified lifting of comparison. --- --- We use this type class to help resolve the constraints for `Ord2` and --- `SymOrd2`. -class UnifiedSymOrd2 mode f where - withBaseSymOrd2 :: (((If (IsConMode mode) (Ord2 f) (SymOrd2 f)) => r)) -> r - -instance - {-# INCOHERENT #-} - (Typeable mode, If (IsConMode mode) (Ord a) (SymOrd a)) => - UnifiedSymOrd mode a - where - withBaseSymOrd r = r - {-# INLINE withBaseSymOrd #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (Ord1 f) (SymOrd1 f), - forall a. (UnifiedSymOrd mode a) => UnifiedSymOrd mode (f a) - ) => - UnifiedSymOrd1 mode f - where - withBaseSymOrd1 r = r - {-# INLINE withBaseSymOrd1 #-} - -instance - {-# INCOHERENT #-} - ( Typeable mode, - If (IsConMode mode) (Ord2 f) (SymOrd2 f), - forall a. (UnifiedSymOrd mode a) => UnifiedSymOrd1 mode (f a) - ) => - UnifiedSymOrd2 mode f - where - withBaseSymOrd2 r = r - {-# INLINE withBaseSymOrd2 #-} - -instance (UnifiedSymOrd 'S v) => UnifiedSymOrd 'S (Union v) where - withBaseSymOrd r = withBaseSymOrd @'S @v r - {-# INLINE withBaseSymOrd #-} - -instance - (Typeable mode, UnifiedSymOrd mode a, Integral a) => - UnifiedSymOrd mode (Ratio a) - where - withBaseSymOrd r = - withMode @mode (withBaseSymOrd @mode @a r) (withBaseSymOrd @mode @a r) - {-# INLINE withBaseSymOrd #-} - -deriveFunctorArgUnifiedInterfaces - ''UnifiedSymOrd - 'withBaseSymOrd - ''UnifiedSymOrd1 - 'withBaseSymOrd1 - [ ''Bool, - ''Integer, - ''Char, - ''Int, - ''Int8, - ''Int16, - ''Int32, - ''Int64, - ''Word, - ''Word8, - ''Word16, - ''Word32, - ''Word64, - ''Float, - ''Double, - ''B.ByteString, - ''T.Text, - ''FPRoundingMode, - ''WordN, - ''IntN, - ''[], - ''Maybe, - ''Either, - ''(), - ''(,), - ''(,,), - ''(,,,), - ''(,,,,), - ''(,,,,,), - ''(,,,,,,), - ''(,,,,,,,), - ''(,,,,,,,,), - ''(,,,,,,,,,), - ''(,,,,,,,,,,), - ''(,,,,,,,,,,,), - ''(,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,), - ''(,,,,,,,,,,,,,,), - ''AssertionError, - ''VerificationConditions, - ''ExceptT, - ''MaybeT, - ''WriterLazy.WriterT, - ''WriterStrict.WriterT, - ''Identity - ] - -deriveUnifiedInterface1s - ''UnifiedSymOrd - 'withBaseSymOrd - ''UnifiedSymOrd1 - 'withBaseSymOrd1 - [ ''[], - ''Maybe, - ''Either, - ''(,), - ''ExceptT, - ''MaybeT, - ''WriterLazy.WriterT, - ''WriterStrict.WriterT, - ''Identity - ] - --- Sum -instance - ( Typeable mode, - UnifiedSymOrd1 mode f, - UnifiedSymOrd1 mode g, - UnifiedSymOrd mode a - ) => - UnifiedSymOrd mode (Sum f g a) - where - withBaseSymOrd r = - withMode @mode - ( withBaseSymOrd1 @mode @f $ - withBaseSymOrd1 @mode @g $ - withBaseSymOrd @mode @a r - ) - ( withBaseSymOrd1 @mode @f $ - withBaseSymOrd1 @mode @g $ - withBaseSymOrd @mode @a r - ) - {-# INLINE withBaseSymOrd #-} - -instance - (Typeable mode, UnifiedSymOrd1 mode f, UnifiedSymOrd1 mode g) => - UnifiedSymOrd1 mode (Sum f g) - where - withBaseSymOrd1 r = - withMode @mode - (withBaseSymOrd1 @mode @f $ withBaseSymOrd1 @mode @g r) - (withBaseSymOrd1 @mode @f $ withBaseSymOrd1 @mode @g r) - {-# INLINE withBaseSymOrd1 #-} - --- IdentityT -instance - (Typeable mode, UnifiedSymOrd1 mode m, UnifiedSymOrd mode a) => - UnifiedSymOrd mode (IdentityT m a) - where - withBaseSymOrd r = - withMode @mode - (withBaseSymOrd1 @mode @m $ withBaseSymOrd @mode @a r) - (withBaseSymOrd1 @mode @m $ withBaseSymOrd @mode @a r) - {-# INLINE withBaseSymOrd #-} - -instance - (Typeable mode, UnifiedSymOrd1 mode m) => - UnifiedSymOrd1 mode (IdentityT m) - where - withBaseSymOrd1 r = - withMode @mode (withBaseSymOrd1 @mode @m r) (withBaseSymOrd1 @mode @m r) - {-# INLINE withBaseSymOrd1 #-} - -instance (Typeable mode, ValidFP eb sb) => UnifiedSymOrd mode (FP eb sb) where - withBaseSymOrd r = withMode @mode r r - {-# INLINE withBaseSymOrd #-} - -instance (Typeable mode) => UnifiedSymOrd2 mode Either where - withBaseSymOrd2 r = withMode @mode r r - {-# INLINE withBaseSymOrd2 #-} - -instance (Typeable mode) => UnifiedSymOrd2 mode (,) where - withBaseSymOrd2 r = withMode @mode r r - {-# INLINE withBaseSymOrd2 #-} - -#if MIN_VERSION_base(4,16,0) -deriveUnifiedInterface1s - ''UnifiedSymOrd - 'withBaseSymOrd - ''UnifiedSymOrd1 - 'withBaseSymOrd1 - [ ''(,,), - ''(,,,) - ] - -instance (Typeable mode, UnifiedSymOrd mode a) => - UnifiedSymOrd2 mode ((,,) a) where - withBaseSymOrd2 r = - withMode @mode (withBaseSymOrd @mode @a r) (withBaseSymOrd @mode @a r) - {-# INLINE withBaseSymOrd2 #-} - -instance - (Typeable mode, UnifiedSymOrd mode a, UnifiedSymOrd mode b) => - UnifiedSymOrd2 mode ((,,,) a b) - where - withBaseSymOrd2 r = - withMode @mode - (withBaseSymOrd @mode @a $ withBaseSymOrd @mode @b r) - (withBaseSymOrd @mode @a $ withBaseSymOrd @mode @b r) - {-# INLINE withBaseSymOrd2 #-} -#endif diff --git a/src/Grisette/Unified/Internal/EvalMode.hs b/src/Grisette/Unified/Internal/EvalMode.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/EvalMode.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- | --- Module : Grisette.Unified.Internal.EvalMode --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.EvalMode - ( EvalModeBase, - EvalModeInteger, - EvalModeBV, - EvalModeFP, - EvalModeAlgReal, - EvalModeAll, - MonadEvalModeAll, - genEvalMode, - ) -where - -import Data.List (nub) -import Data.Maybe (mapMaybe) -import Data.Typeable (Typeable) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) -import Grisette.Unified.Internal.BVBVConversion (AllUnifiedBVBVConversion) -import Grisette.Unified.Internal.BVFPConversion (AllUnifiedBVFPConversion) -import Grisette.Unified.Internal.BaseMonad (BaseMonad) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.FPFPConversion (AllUnifiedFPFPConversion) -import Grisette.Unified.Internal.Theories - ( TheoryToUnify (UAlgReal, UFP, UFun, UIntN, UInteger, UWordN), - isUFun, - ) -import Grisette.Unified.Internal.UnifiedAlgReal (UnifiedAlgReal) -import Grisette.Unified.Internal.UnifiedBV (AllUnifiedBV) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.UnifiedData (AllUnifiedData) -import Grisette.Unified.Internal.UnifiedFP (AllUnifiedFP) -import Grisette.Unified.Internal.UnifiedFun - ( genUnifiedFunInstance, - unifiedFunInstanceName, - ) -import Grisette.Unified.Internal.UnifiedInteger (UnifiedInteger) -import Grisette.Unified.Internal.UnifiedPrim (UnifiedBasicPrim) -import Language.Haskell.TH - ( DecsQ, - Type (AppT, ArrowT, ConT, StarT, VarT), - appT, - classD, - conT, - instanceD, - kindedTV, - mkName, - newName, - promotedT, - tySynD, - varT, - ) - --- | Provide the constraint that the mode is a valid evaluation mode, and --- provides the support for 'GetBool' and 'Grisette.Unified.GetData'. --- --- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. -class - ( Typeable mode, - UnifiedBool mode, - UnifiedBasicPrim mode (GetBool mode), - Monad (BaseMonad mode), - TryMerge (BaseMonad mode), - UnifiedBranching mode (BaseMonad mode), - AllUnifiedData mode - ) => - EvalModeBase mode - -instance EvalModeBase 'C - -instance EvalModeBase 'S - --- | Provide the support for 'Grisette.Unified.GetIntN', --- 'Grisette.Unified.GetWordN', 'Grisette.Unified.GetSomeIntN', and --- 'Grisette.Unified.GetSomeWordN'. --- --- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. -class (AllUnifiedBV mode, AllUnifiedBVBVConversion mode) => EvalModeBV mode - -instance EvalModeBV 'C - -instance EvalModeBV 'S - --- | Provide the support for 'Grisette.Unified.GetInteger'. --- --- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. -type EvalModeInteger = UnifiedInteger - --- | Provide the support for 'Grisette.Unified.GetFP' and --- 'Grisette.Unified.GetFPRoundingMode'. --- --- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. -class - ( AllUnifiedFP mode, - AllUnifiedFPFPConversion mode, - AllUnifiedBVFPConversion mode - ) => - EvalModeFP mode - -instance EvalModeFP 'C - -instance EvalModeFP 'S - --- | Provide the support for 'Grisette.Unified.GetAlgReal'. --- --- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. -type EvalModeAlgReal = UnifiedAlgReal - --- | A constraint that specifies that the mode is valid, and provide all the --- corresponding constraints for the operaions for the types. --- --- Note for users with GHC prior to 9.2.1: the GHC compiler isn't able to --- resolve the operations for sized bitvectors and data types. In this case, --- you may need to provide `Grisette.Unified.Internal.UnifiedBV.UnifiedBV`, --- `Grisette.Unified.Internal.UnifiedBV.SafeUnifiedBV`, --- `Grisette.Unified.Internal.UnifiedBV.SafeUnifiedSomeBV`, and --- `Grisette.Unified.Internal.UnifiedData.UnifiedData` constraints manually. --- --- For example, the following code is valid for GHC 9.2.1 and later: --- --- > fbv :: --- > forall mode n. --- > (EvalMode mode, KnownNat n, 1 <= n) => --- > GetIntN mode n -> --- > GetIntN mode n -> --- > GetIntN mode n --- > fbv l r = --- > mrgIte @mode --- > (l .== r) --- > (l + r) --- > (symIte @mode (l .< r) l r) --- --- But with older GHCs, you need to write: --- --- > fbv :: --- > forall mode n. --- > (EvalMode mode, KnownNat n, 1 <= n, UnifiedBV mode n) => --- > GetIntN mode n -> --- > GetIntN mode n -> --- > GetIntN mode n --- > fbv l r = --- > mrgIte @mode --- > (l .== r) --- > (l + r) --- > (symIte @mode (l .< r) l r) -class - ( EvalModeBase mode, - EvalModeInteger mode, - EvalModeAlgReal mode, - EvalModeBV mode, - EvalModeFP mode - ) => - EvalModeAll mode - -instance EvalModeAll 'C - -instance EvalModeAll 'S - --- | A constraint that specifies that the mode is valid, and provide all the --- corresponding constraints for the operations for the types. --- --- This also provide the branching constraints for the monad, and the safe --- operations: for example, 'Grisette.Unified.SafeUnifiedInteger' provides --- 'Grisette.safeDiv' for the integer type with in @ExceptT ArithException m@. --- --- For users with GHC prior to 9.2.1, see notes in 'EvalModeAll'. -type MonadEvalModeAll mode m = - ( EvalModeAll mode, - Monad m, - TryMerge m, - UnifiedBranching mode m - ) - --- | This template haskell function generates an EvalMode constraint on demand. --- --- For example, if in your system, you are only working on bit-vectors and --- booleans, but not floating points, integers, or real numbers, you can use --- this function to generate a constraint that only includes the necessary --- constraints: --- --- > genEvalMode "MyEvalMode" [UWordN, UIntN, UBool] --- > f :: MyEvalMode mode => GetBool mode -> GetWordN mode 8 -> GetWordN mode 8 --- > f = ... --- --- This may help with faster compilation times. --- --- Another usage of this custom constraint is to working with uninterpreted --- functions. The uninterpreted functions aren't available even with --- 'EvalModeAll', and is only available with the constraint generated by this --- function. Note that you need to explicitly list all the uninterpreted --- function types you need in your system. --- --- > genEvalMode "MyEvalModeUF" [UFun [UWordN, UIntN], UFun [UBool, UBool, UWordN]] --- --- This will give us a constraint that allows us to work with booleans and --- bit-vectors, and also the uninterpreted functions that --- --- * maps an unsigned bit-vector (any bitwidth) to an unsigned integer (any --- bitwidth), and --- * maps two booleans to an unsigned bit-vector (any bitwidth). --- --- You can then use them in your code like this: --- --- > f :: MyEvalModeUF mode => GetFun mode (GetWordN mode 8) (GetIntN mode 8) -> GetIntN mode 8 --- > f fun = f # 1 --- --- The function will also provide the constraint @MonadMyEvalModeUF@, which --- includes the constraints for the monad and the unified branching, similar to --- 'MonadEvalModeAll'. --- --- For compilers older than GHC 9.2.1, see the notes for 'EvalModeAll'. This --- function will also generate constraints like @MyEvalModeUFFunUWordNUIntN@, --- which can be used to resolve the constraints for older compilers. --- --- The naming conversion is the concatenation of the three parts: --- --- * The base name provided by the user (i.e., @MyEvalModeUF@), --- * @Fun@, --- * The concatenation of all the types in the uninterpreted function (i.e., --- @UWordNUIntN@). --- --- The arguments to the type class is as follows: --- --- * The first argument is the mode, --- * The second to the end arguments are the natural number arguments for all --- the types. Here the second argument is the bitwidth of the unsigned --- bit-vector argument, and the third argument is the bitwidth of the signed --- bit-vector result. -genEvalMode :: String -> [TheoryToUnify] -> DecsQ -genEvalMode nm theories = do - modeName <- newName "mode" - let modeType = VarT modeName - baseConstraint <- [t|EvalModeBase $(return modeType)|] - basicConstraints <- concat <$> traverse (nonFuncConstraint modeType) nonFuncs - funcInstances <- concat <$> traverse (genUnifiedFunInstance nm) funcs - let instanceNames = ("All" ++) . unifiedFunInstanceName nm <$> funcs - funcConstraints <- traverse (genFunConstraint (return modeType)) instanceNames - r <- - classD - (return $ baseConstraint : basicConstraints ++ funcConstraints) - (mkName nm) - [kindedTV modeName (ConT ''EvalModeTag)] - [] - [] - rc <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'C)) [] - rs <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'S)) [] - m <- newName "m" - let mType = varT m - monad <- - tySynD - (mkName $ "Monad" ++ nm) - [ kindedTV modeName (ConT ''EvalModeTag), - kindedTV m (AppT (AppT ArrowT StarT) StarT) - ] - [t| - ( $(appT (conT $ mkName nm) (return modeType)), - Monad $mType, - TryMerge $mType, - UnifiedBranching $(return modeType) $mType - ) - |] - return $ funcInstances ++ [r, rc, rs, monad] - where - nonFuncs = - nub $ - (\x -> if x == UIntN then UWordN else x) - <$> filter (not . isUFun) (theories ++ concat funcs) - funcs = - nub $ - mapMaybe - ( \case - UFun x -> Just x - _ -> Nothing - ) - theories - nonFuncConstraint mode UInteger = - (: []) <$> [t|EvalModeInteger $(return mode)|] - nonFuncConstraint mode UAlgReal = - (: []) <$> [t|EvalModeAlgReal $(return mode)|] - nonFuncConstraint mode UWordN = - (: []) <$> [t|EvalModeBV $(return mode)|] - nonFuncConstraint mode UFP = (: []) <$> [t|EvalModeFP $(return mode)|] - nonFuncConstraint _ _ = return [] - genFunConstraint mode name = appT (conT (mkName name)) mode diff --git a/src/Grisette/Unified/Internal/EvalModeTag.hs b/src/Grisette/Unified/Internal/EvalModeTag.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/EvalModeTag.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilyDependencies #-} - --- | --- Module : Grisette.Unified.Internal.EvalModeTag --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (..), - IsConMode, - ) -where - -import Language.Haskell.TH.Syntax (Lift) - --- | Evaluation mode for unified types. 'C' means concrete evaluation, 'S' --- means symbolic evaluation. -data EvalModeTag = C | S deriving (Lift) - --- | Type family to check if a mode is 'C'. -type family IsConMode (mode :: EvalModeTag) = (r :: Bool) | r -> mode where - IsConMode 'C = 'True - IsConMode 'S = 'False diff --git a/src/Grisette/Unified/Internal/FPFPConversion.hs b/src/Grisette/Unified/Internal/FPFPConversion.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/FPFPConversion.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.FPFPConversion --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.FPFPConversion - ( UnifiedFPFPConversion, - AllUnifiedFPFPConversion, - ) -where - -import Grisette.Internal.Core.Data.Class.IEEEFP (IEEEFPConvertible) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedFP (UnifiedFPImpl (GetFP, GetFPRoundingMode)) - -class - ( UnifiedFPImpl mode fpn eb0 sb0 fp0 fprd, - UnifiedFPImpl mode fpn eb1 sb1 fp1 fprd, - IEEEFPConvertible fp0 fp1 fprd - ) => - UnifiedFPFPConversionImpl - (mode :: EvalModeTag) - fpn - eb0 - sb0 - eb1 - sb1 - fp0 - fp1 - fprd - -instance - (ValidFP eb0 sb0, ValidFP eb1 sb1) => - UnifiedFPFPConversionImpl - 'C - FP - eb0 - sb0 - eb1 - sb1 - (FP eb0 sb0) - (FP eb1 sb1) - FPRoundingMode - -instance - (ValidFP eb0 sb0, ValidFP eb1 sb1) => - UnifiedFPFPConversionImpl - 'S - SymFP - eb0 - sb0 - eb1 - sb1 - (SymFP eb0 sb0) - (SymFP eb1 sb1) - SymFPRoundingMode - --- | Unified constraints for conversion from floating point numbers to floating --- point numbers. -class - ( UnifiedFPFPConversionImpl - (mode :: EvalModeTag) - (GetFP mode) - eb0 - sb0 - eb1 - sb1 - (GetFP mode eb0 sb0) - (GetFP mode eb1 sb1) - (GetFPRoundingMode mode) - ) => - UnifiedFPFPConversion mode eb0 sb0 eb1 sb1 - -instance - ( UnifiedFPFPConversionImpl - (mode :: EvalModeTag) - (GetFP mode) - eb0 - sb0 - eb1 - sb1 - (GetFP mode eb0 sb0) - (GetFP mode eb1 sb1) - (GetFPRoundingMode mode) - ) => - UnifiedFPFPConversion mode eb0 sb0 eb1 sb1 - --- | Evaluation mode with unified conversion from floating-points to --- floating-points. -class - ( forall eb0 sb0 eb1 sb1. - (ValidFP eb0 sb0, ValidFP eb1 sb1) => - UnifiedFPFPConversion - mode - eb0 - sb0 - eb1 - sb1 - ) => - AllUnifiedFPFPConversion mode - -instance - ( forall eb0 sb0 eb1 sb1. - (ValidFP eb0 sb0, ValidFP eb1 sb1) => - UnifiedFPFPConversion - mode - eb0 - sb0 - eb1 - sb1 - ) => - AllUnifiedFPFPConversion mode diff --git a/src/Grisette/Unified/Internal/Theories.hs b/src/Grisette/Unified/Internal/Theories.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Theories.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | --- Module : Grisette.Unified.Internal.Theories --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Theories (TheoryToUnify (..), isUFun) where - --- | This data type is used to represent the theories that is unified. --- --- The 'UFun' constructor is used to represent a specific uninterpreted function --- type. The type is uncurried. -data TheoryToUnify - = UBool - | UIntN - | UWordN - | UInteger - | UAlgReal - | UFP - | UFun [TheoryToUnify] - deriving (Eq, Show) - --- | Check if the theory is a uninterpreted function. -isUFun :: TheoryToUnify -> Bool -isUFun (UFun _) = True -isUFun _ = False diff --git a/src/Grisette/Unified/Internal/UnifiedAlgReal.hs b/src/Grisette/Unified/Internal/UnifiedAlgReal.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedAlgReal.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedAlgReal --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedAlgReal - ( UnifiedAlgReal, - GetAlgReal, - ) -where - -import Control.Exception (ArithException) -import Control.Monad.Error.Class (MonadError) -import Grisette.Internal.Core.Data.Class.SafeFdiv (FdivOr) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymPrim (Prim) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral (UnifiedFromIntegral) -import Grisette.Unified.Internal.Class.UnifiedRep - ( UnifiedConRep (ConType), - UnifiedSymRep (SymType), - ) -import Grisette.Unified.Internal.Class.UnifiedSafeFdiv (UnifiedSafeFdiv) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedInteger (GetInteger) -import Grisette.Unified.Internal.UnifiedPrim (UnifiedBasicPrim) - -class - ( r ~ GetAlgReal mode, - UnifiedConRep r, - UnifiedSymRep r, - ConType r ~ AlgReal, - SymType r ~ SymAlgReal, - UnifiedBasicPrim mode r, - Prim r, - Num r, - Fractional r, - FdivOr r, - forall m. - (UnifiedBranching mode m, MonadError ArithException m) => - UnifiedSafeFdiv mode ArithException r m, - UnifiedFromIntegral mode (GetInteger mode) r - ) => - UnifiedAlgRealImpl (mode :: EvalModeTag) r - | mode -> r - where - -- | Get a unified algebraic real type. Resolves to 'AlgReal' in 'C' mode, - -- and 'SymAlgReal' in 'S' mode. - -- - -- 'Floating', 'Grisette.LogBaseOr' and 'Grisette.SafeLogBase' for - -- 'SymAlgReal' are not provided as they are not available for 'AlgReal'. - type GetAlgReal mode = real | real -> mode - -instance UnifiedAlgRealImpl 'C AlgReal where - type GetAlgReal 'C = AlgReal - -instance UnifiedAlgRealImpl 'S SymAlgReal where - type GetAlgReal 'S = SymAlgReal - --- | Evaluation mode with unified 'AlgReal' type. -class - (UnifiedAlgRealImpl mode (GetAlgReal mode)) => - UnifiedAlgReal (mode :: EvalModeTag) - -instance UnifiedAlgReal 'C - -instance UnifiedAlgReal 'S diff --git a/src/Grisette/Unified/Internal/UnifiedBV.hs b/src/Grisette/Unified/Internal/UnifiedBV.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedBV.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedBV --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedBV - ( GetWordN, - GetIntN, - UnifiedBVImpl, - UnifiedBV, - GetSomeWordN, - GetSomeIntN, - SafeUnifiedBV, - SafeUnifiedSomeBV, - AllUnifiedBV, - ) -where - -import Control.Exception (ArithException) -import Control.Monad.Except (MonadError) -import Data.Bits (Bits, FiniteBits) -import Data.Kind (Constraint, Type) -import GHC.TypeNats (KnownNat, Nat, type (<=)) -import Grisette.Internal.Core.Data.Class.BitCast (BitCast) -import Grisette.Internal.Core.Data.Class.BitVector (BV, SizedBV) -import Grisette.Internal.Core.Data.Class.SafeDiv (DivOr) -import Grisette.Internal.Core.Data.Class.SignConversion (SignConversion) -import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Internal.Core.Data.Class.SymShift (SymShift) -import Grisette.Internal.SymPrim.BV - ( IntN, - WordN, - ) -import Grisette.Internal.SymPrim.SomeBV - ( SomeBV, - SomeBVException, - SomeIntN, - SomeSymIntN, - SomeSymWordN, - SomeWordN, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Unified.Internal.BaseConstraint (ConSymConversion) -import Grisette.Unified.Internal.Class.UnifiedFiniteBits - ( UnifiedFiniteBits, - ) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral (UnifiedFromIntegral) -import Grisette.Unified.Internal.Class.UnifiedRep - ( UnifiedConRep (ConType), - UnifiedSymRep (SymType), - ) -import Grisette.Unified.Internal.Class.UnifiedSafeDiv (UnifiedSafeDiv) -import Grisette.Unified.Internal.Class.UnifiedSafeLinearArith - ( UnifiedSafeLinearArith, - ) -import Grisette.Unified.Internal.Class.UnifiedSafeSymRotate - ( UnifiedSafeSymRotate, - ) -import Grisette.Unified.Internal.Class.UnifiedSafeSymShift (UnifiedSafeSymShift) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching, - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedAlgReal (GetAlgReal) -import Grisette.Unified.Internal.UnifiedInteger (GetInteger) -import Grisette.Unified.Internal.UnifiedPrim (UnifiedBasicPrim, UnifiedPrim) - -type BVConstraint mode word int = - ( Num word, - Num int, - Bits word, - Bits int, - FiniteBits word, - FiniteBits int, - SymShift word, - SymShift int, - SymRotate word, - SymRotate int, - SignConversion word int, - UnifiedFiniteBits mode word, - UnifiedFiniteBits mode int - ) :: - Constraint - -type SomeBVPair mode word int = - ( UnifiedPrim mode word, - UnifiedPrim mode int, - BVConstraint mode word int, - BV word, - BV int, - DivOr word, - DivOr int, - ConSymConversion SomeWordN SomeSymWordN word, - ConSymConversion SomeIntN SomeSymIntN int - ) :: - Constraint - --- | Implementation for 'UnifiedBV'. -class - ( UnifiedConRep word, - UnifiedSymRep int, - ConType word ~ WordN n, - SymType word ~ SymWordN n, - ConType int ~ IntN n, - SymType int ~ SymIntN n, - UnifiedBasicPrim mode word, - UnifiedBasicPrim mode int, - BVConstraint mode word int, - wordn ~ GetWordN mode, - intn ~ GetIntN mode, - word ~ wordn n, - int ~ intn n, - BitCast word int, - BitCast int word, - DivOr word, - DivOr int, - UnifiedFromIntegral mode (GetInteger mode) word, - UnifiedFromIntegral mode (GetInteger mode) int, - UnifiedFromIntegral mode word (GetInteger mode), - UnifiedFromIntegral mode word (GetAlgReal mode), - UnifiedFromIntegral mode int (GetInteger mode), - UnifiedFromIntegral mode int (GetAlgReal mode) - ) => - UnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int - | wordn -> intn, - intn -> wordn, - wordn n -> word, - word -> wordn n, - intn n -> int, - int -> intn n - where - -- | Get a unified unsigned size-tagged bit vector type. Resolves to 'WordN' - -- in 'C' mode, and 'SymWordN' in 'S' mode. - type GetWordN mode = (w :: Nat -> Type) | w -> mode - - -- | Get a unified signed size-tagged bit vector type. Resolves to 'IntN' - -- in 'C' mode, and 'SymIntN' in 'S' mode. - type GetIntN mode = (i :: Nat -> Type) | i -> mode - -instance - (KnownNat n, 1 <= n) => - UnifiedBVImpl 'C WordN IntN n (WordN n) (IntN n) - where - type GetWordN 'C = WordN - type GetIntN 'C = IntN - -instance - (KnownNat n, 1 <= n) => - UnifiedBVImpl 'S SymWordN SymIntN n (SymWordN n) (SymIntN n) - where - type GetWordN 'S = SymWordN - type GetIntN 'S = SymIntN - --- | Get a unified unsigned dynamic bit width bit vector type. Resolves to --- 'SomeWordN' in 'C' mode, and 'SomeSymWordN' in 'S' mode. -type family GetSomeWordN mode = sw | sw -> mode where - GetSomeWordN mode = SomeBV (GetWordN mode) - --- | Get a unified signed dynamic bit width bit vector type. Resolves to --- 'SomeIntN' in 'C' mode, and 'SomeSymIntN' in 'S' mode. -type family GetSomeIntN mode = sw | sw -> mode where - GetSomeIntN mode = SomeBV (GetIntN mode) - --- | This class is needed as constraint in user code prior to GHC 9.2.1. --- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. -class - ( UnifiedBVImpl - mode - (GetWordN mode) - (GetIntN mode) - n - (GetWordN mode n) - (GetIntN mode n) - ) => - UnifiedBV mode n - -instance - ( UnifiedBVImpl - mode - (GetWordN mode) - (GetIntN mode) - n - (GetWordN mode n) - (GetIntN mode n) - ) => - UnifiedBV mode n - -class - ( UnifiedSafeDiv mode ArithException word m, - UnifiedSafeLinearArith mode ArithException word m, - UnifiedSafeSymShift mode ArithException word m, - UnifiedSafeSymRotate mode ArithException word m, - UnifiedSafeDiv mode ArithException int m, - UnifiedSafeLinearArith mode ArithException int m, - UnifiedSafeSymShift mode ArithException int m, - UnifiedSafeSymRotate mode ArithException int m, - UnifiedBVImpl mode wordn intn n word int - ) => - SafeUnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int m - -instance - ( UnifiedSafeDiv mode ArithException word m, - UnifiedSafeLinearArith mode ArithException word m, - UnifiedSafeSymShift mode ArithException word m, - UnifiedSafeSymRotate mode ArithException word m, - UnifiedSafeDiv mode ArithException int m, - UnifiedSafeLinearArith mode ArithException int m, - UnifiedSafeSymShift mode ArithException int m, - UnifiedSafeSymRotate mode ArithException int m, - UnifiedBVImpl mode wordn intn n word int - ) => - SafeUnifiedBVImpl mode wordn intn n word int m - --- | This class is needed as constraint in user code prior to GHC 9.2.1. --- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. -class - ( SafeUnifiedBVImpl - mode - (GetWordN mode) - (GetIntN mode) - n - (GetWordN mode n) - (GetIntN mode n) - m - ) => - SafeUnifiedBV mode n m - -instance - ( SafeUnifiedBVImpl - mode - (GetWordN mode) - (GetIntN mode) - n - (GetWordN mode n) - (GetIntN mode n) - m - ) => - SafeUnifiedBV mode n m - -class - ( SomeBVPair mode word int, - UnifiedSafeDiv mode (Either SomeBVException ArithException) word m, - UnifiedSafeLinearArith mode (Either SomeBVException ArithException) word m, - UnifiedSafeSymRotate mode (Either SomeBVException ArithException) word m, - UnifiedSafeSymShift mode (Either SomeBVException ArithException) word m, - UnifiedSafeDiv mode (Either SomeBVException ArithException) int m, - UnifiedSafeLinearArith mode (Either SomeBVException ArithException) int m, - UnifiedSafeSymRotate mode (Either SomeBVException ArithException) int m, - UnifiedSafeSymShift mode (Either SomeBVException ArithException) int m - ) => - SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m - -instance - ( SomeBVPair mode word int, - UnifiedSafeDiv mode (Either SomeBVException ArithException) word m, - UnifiedSafeLinearArith mode (Either SomeBVException ArithException) word m, - UnifiedSafeSymRotate mode (Either SomeBVException ArithException) word m, - UnifiedSafeSymShift mode (Either SomeBVException ArithException) word m, - UnifiedSafeDiv mode (Either SomeBVException ArithException) int m, - UnifiedSafeLinearArith mode (Either SomeBVException ArithException) int m, - UnifiedSafeSymRotate mode (Either SomeBVException ArithException) int m, - UnifiedSafeSymShift mode (Either SomeBVException ArithException) int m - ) => - SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m - --- | This class is needed as constraint in user code prior to GHC 9.2.1. --- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. -class - ( SafeUnifiedSomeBVImpl - mode - (SomeBV (GetWordN mode)) - (SomeBV (GetIntN mode)) - m - ) => - SafeUnifiedSomeBV mode m - -instance - ( SafeUnifiedSomeBVImpl - mode - (SomeBV (GetWordN mode)) - (SomeBV (GetIntN mode)) - m - ) => - SafeUnifiedSomeBV mode m - --- | Evaluation mode with unified bit vector types. -class - ( forall n m. - ( UnifiedBranching mode m, - MonadError ArithException m, - KnownNat n, - 1 <= n - ) => - SafeUnifiedBV mode n m, - forall m. - ( UnifiedBranching mode m, - MonadError (Either SomeBVException ArithException) m - ) => - SafeUnifiedSomeBV mode m, - forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n, - SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode), - SizedBV (GetWordN mode), - SizedBV (GetIntN mode) - ) => - AllUnifiedBV mode - -instance - ( forall n m. - ( UnifiedBranching mode m, - MonadError ArithException m, - KnownNat n, - 1 <= n - ) => - SafeUnifiedBV mode n m, - forall m. - ( UnifiedBranching mode m, - MonadError (Either SomeBVException ArithException) m - ) => - SafeUnifiedSomeBV mode m, - forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n, - SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode), - SizedBV (GetWordN mode), - SizedBV (GetIntN mode) - ) => - AllUnifiedBV mode diff --git a/src/Grisette/Unified/Internal/UnifiedBool.hs b/src/Grisette/Unified/Internal/UnifiedBool.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedBool.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedBool --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedBool (UnifiedBool (..)) where - -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymPrim (Prim) -import Grisette.Unified.Internal.BaseConstraint - ( ConSymConversion, - ) -import Grisette.Unified.Internal.Class.UnifiedRep - ( UnifiedConRep (ConType), - UnifiedSymRep (SymType), - ) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) - --- | Evaluation mode with unified 'Bool' type. -class - ( Prim (GetBool mode), - UnifiedConRep (GetBool mode), - UnifiedSymRep (GetBool mode), - ConType (GetBool mode) ~ Bool, - SymType (GetBool mode) ~ SymBool, - ConSymConversion Bool SymBool (GetBool mode), - LogicalOp (GetBool mode) - ) => - UnifiedBool (mode :: EvalModeTag) - where - -- | Get a unified Boolean type. Resolves to 'Bool' in 'C' mode, and - -- 'SymBool' in 'S' mode. - type GetBool mode = bool | bool -> mode - -instance UnifiedBool 'C where - type GetBool 'C = Bool - -instance UnifiedBool 'S where - type GetBool 'S = SymBool diff --git a/src/Grisette/Unified/Internal/UnifiedData.hs b/src/Grisette/Unified/Internal/UnifiedData.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedData.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedData --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedData - ( GetData, - wrapData, - extractData, - UnifiedData, - AllUnifiedData, - ) -where - -import Control.DeepSeq (NFData) -import Control.Monad.Identity (Identity (Identity, runIdentity)) -import Data.Bytes.Serial (Serial) -import Data.Hashable (Hashable) -import Grisette.Internal.Core.Control.Monad.Union (Union) -import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) -import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.PPrint (PPrint) -import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) -import Grisette.Internal.Core.Data.Class.SymEq (SymEq) -import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) -import Grisette.Internal.Core.Data.Class.ToCon (ToCon) -import Grisette.Internal.Core.Data.Class.ToSym (ToSym) -import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) -import Grisette.Internal.SymPrim.AllSyms (AllSyms) -import Grisette.Unified.Internal.Class.UnifiedITEOp (UnifiedITEOp) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedBranching (withBaseBranching), - UnifiedSimpleMergeable, - liftBaseMonad, - ) -import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq) -import Grisette.Unified.Internal.Class.UnifiedSymOrd (UnifiedSymOrd) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Instances.TH.Lift () -import Language.Haskell.TH.Syntax (Lift) - -class - ( u ~ GetData mode v, - Mergeable u, - (AllSyms v) => AllSyms u, - (Eq v) => Eq u, - (EvalSym v) => EvalSym u, - (ExtractSym v) => ExtractSym u, - (ITEOp v) => ITEOp u, - (PPrint v) => PPrint u, - (Hashable v) => Hashable u, - (Lift v) => Lift u, - (LogicalOp v) => LogicalOp u, - (NFData v) => NFData u, - (Num v) => Num u, - (SymEq v) => SymEq u, - (Show v) => Show u, - (SymOrd v) => SymOrd u, - (SubstSym v) => SubstSym u, - (Serial v) => Serial u, - (UnifiedITEOp mode v) => UnifiedITEOp mode u, - (UnifiedSimpleMergeable mode v) => UnifiedSimpleMergeable mode u, - (UnifiedSymEq mode v) => UnifiedSymEq mode u, - (UnifiedSymOrd mode v) => UnifiedSymOrd mode u, - forall b. (ToCon v b) => ToCon u b, - forall a. (ToSym a v) => ToSym a u - ) => - UnifiedDataImpl (mode :: EvalModeTag) v u - | u -> mode v - where - -- | Get a unified data type. Resolves to @v@ in 'C' mode, and @'Union' v@ - -- in 'S' mode. - type GetData mode v = r | r -> mode v - - -- | Wraps a value into the unified data type. - wrapData :: v -> u - - -- | Extracts a value from the unified data type. - extractData :: (Monad m, UnifiedBranching mode m) => u -> m v - -instance (Mergeable v) => UnifiedDataImpl 'C v (Identity v) where - type GetData 'C v = Identity v - wrapData = Identity - extractData :: - forall m. (Mergeable v, Monad m, UnifiedBranching C m) => Identity v -> m v - extractData = withBaseBranching @'C @m $ mrgSingle . runIdentity - -instance (Mergeable v) => UnifiedDataImpl 'S v (Union v) where - type GetData 'S v = Union v - wrapData = mrgSingle - extractData :: - forall m. (Mergeable v, Monad m, UnifiedBranching S m) => Union v -> m v - extractData = liftBaseMonad - --- | This class is needed as constraint in user code prior to GHC 9.2.1. --- See the notes in 'Grisette.Unified.Internal.IsMode.IsMode'. -class (UnifiedDataImpl mode v (GetData mode v)) => UnifiedData mode v - -instance (UnifiedDataImpl bool v (GetData bool v)) => UnifiedData bool v - -class - (UnifiedSimpleMergeable 'S (GetData 'S v)) => - UnifiedDataSimpleMergeable v - -instance (Mergeable v) => UnifiedDataSimpleMergeable v - --- | Evaluation mode with unified data types. -class - ( forall v. (Mergeable v) => UnifiedData bool v, - forall v. (Mergeable v) => UnifiedDataSimpleMergeable v - ) => - AllUnifiedData bool - -instance - ( forall v. (Mergeable v) => UnifiedData bool v, - forall v. (Mergeable v) => UnifiedDataSimpleMergeable v - ) => - AllUnifiedData bool diff --git a/src/Grisette/Unified/Internal/UnifiedFP.hs b/src/Grisette/Unified/Internal/UnifiedFP.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedFP.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedFP --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedFP - ( GetFP, - GetFPRoundingMode, - UnifiedFP, - SafeUnifiedFP, - AllUnifiedFP, - UnifiedFPImpl, - ) -where - -import Control.Monad.Error.Class (MonadError) -import Data.Kind (Type) -import GHC.TypeNats (Nat) -import Grisette.Internal.Core.Data.Class.IEEEFP - ( IEEEFPConstants, - IEEEFPConvertible, - IEEEFPOp, - IEEEFPRoundingOp, - IEEEFPToAlgReal, - ) -import Grisette.Internal.Core.Data.Class.SymIEEEFP (SymIEEEFPTraits) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral (UnifiedFromIntegral) -import Grisette.Unified.Internal.Class.UnifiedRep (UnifiedConRep (ConType), UnifiedSymRep (SymType)) -import Grisette.Unified.Internal.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedAlgReal (GetAlgReal) -import Grisette.Unified.Internal.UnifiedInteger (GetInteger) -import Grisette.Unified.Internal.UnifiedPrim (UnifiedBasicPrim) - --- | Implementation for 'UnifiedFP'. -class - ( UnifiedConRep fp, - UnifiedSymRep fp, - ConType fp ~ FP eb sb, - SymType fp ~ SymFP eb sb, - UnifiedBasicPrim mode fp, - Floating fp, - SymIEEEFPTraits fp, - IEEEFPConstants fp, - IEEEFPOp fp, - IEEEFPRoundingOp fp rd, - UnifiedFromIntegral mode (GetInteger mode) fp, - IEEEFPToAlgReal (GetAlgReal mode) fp rd, - IEEEFPConvertible (GetInteger mode) fp rd, - fpn ~ GetFP mode, - fp ~ fpn eb sb, - rd ~ GetFPRoundingMode mode - ) => - UnifiedFPImpl (mode :: EvalModeTag) fpn eb sb fp rd - | fpn eb sb -> fp rd, - fp -> fpn eb sb rd, - rd -> fpn, - rd eb sb -> fp - where - -- | Get a unified floating point type. Resolves to 'FP' in 'C' mode, and - -- 'SymFP' in 'S' mode. - type GetFP mode = (f :: Nat -> Nat -> Type) | f -> mode - - -- | Get a unified floating point rounding mode type. Resolves to - -- 'FPRoundingMode' in 'C' mode, and 'SymFPRoundingMode' in 'S' mode. - type GetFPRoundingMode mode = r | r -> mode - -instance - (ValidFP eb sb) => - UnifiedFPImpl 'C FP eb sb (FP eb sb) FPRoundingMode - where - type GetFP 'C = FP - type GetFPRoundingMode 'C = FPRoundingMode - -instance - (ValidFP eb sb) => - UnifiedFPImpl 'S SymFP eb sb (SymFP eb sb) SymFPRoundingMode - where - type GetFP 'S = SymFP - type GetFPRoundingMode 'S = SymFPRoundingMode - --- | Evaluation mode with unified 'FP' type. -class - ( UnifiedFPImpl - mode - (GetFP mode) - eb - sb - (GetFP mode eb sb) - (GetFPRoundingMode mode) - ) => - UnifiedFP mode eb sb - -instance - ( UnifiedFPImpl - mode - (GetFP mode) - eb - sb - (GetFP mode eb sb) - (GetFPRoundingMode mode) - ) => - UnifiedFP mode eb sb - -class - (UnifiedFPImpl mode fpn eb sb fp rd) => - SafeUnifiedFPImpl mode fpn eb sb fp rd (m :: Type -> Type) - -instance - (UnifiedFPImpl mode fpn eb sb fp rd) => - SafeUnifiedFPImpl mode fpn eb sb fp rd m - --- | This class is needed as constraint in user code prior to GHC 9.2.1. --- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. -class - ( SafeUnifiedFPImpl - mode - (GetFP mode) - eb - sb - (GetFP mode eb sb) - (GetFPRoundingMode mode) - m, - UnifiedSafeFromFP - mode - NotRepresentableFPError - (GetInteger mode) - (GetFP mode eb sb) - (GetFPRoundingMode mode) - m - ) => - SafeUnifiedFP mode eb sb m - -instance - ( SafeUnifiedFPImpl - mode - (GetFP mode) - eb - sb - (GetFP mode eb sb) - (GetFPRoundingMode mode) - m, - UnifiedSafeFromFP - mode - NotRepresentableFPError - (GetInteger mode) - (GetFP mode eb sb) - (GetFPRoundingMode mode) - m - ) => - SafeUnifiedFP mode eb sb m - --- | Evaluation mode with unified floating point type. -class - ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb, - forall eb sb m. - ( ValidFP eb sb, - UnifiedBranching mode m, - MonadError NotRepresentableFPError m - ) => - SafeUnifiedFP mode eb sb m - ) => - AllUnifiedFP mode - -instance - ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb, - forall eb sb m. - ( ValidFP eb sb, - UnifiedBranching mode m, - MonadError NotRepresentableFPError m - ) => - SafeUnifiedFP mode eb sb m - ) => - AllUnifiedFP mode diff --git a/src/Grisette/Unified/Internal/UnifiedFun.hs b/src/Grisette/Unified/Internal/UnifiedFun.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedFun.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedFun --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedFun - ( UnifiedFunConstraint, - UnifiedFun (..), - unifiedFunInstanceName, - genUnifiedFunInstance, - GetFun2, - GetFun3, - GetFun4, - GetFun5, - GetFun6, - GetFun7, - GetFun8, - ) -where - -import Control.DeepSeq (NFData) -import Data.Foldable (Foldable (foldl')) -import Data.Hashable (Hashable) -import qualified Data.Kind -import GHC.TypeLits (KnownNat, Nat, type (<=)) -import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) -import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) -import Grisette.Internal.Core.Data.Class.Function (Apply (FunType), Function) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.PPrint (PPrint) -import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) -import Grisette.Internal.Core.Data.Class.ToCon (ToCon) -import Grisette.Internal.Core.Data.Class.ToSym (ToSym) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, ValidFP) -import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.Theories - ( TheoryToUnify (UAlgReal, UBool, UFP, UFun, UIntN, UInteger, UWordN), - ) -import Grisette.Unified.Internal.UnifiedAlgReal (GetAlgReal) -import Grisette.Unified.Internal.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN)) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) -import Grisette.Unified.Internal.UnifiedFP (UnifiedFPImpl (GetFP)) -import Grisette.Unified.Internal.UnifiedInteger (GetInteger) -import Language.Haskell.TH - ( DecsQ, - Pred, - Q, - TyLit (NumTyLit), - Type (AppT, ConT, ForallT, LitT, VarT), - appT, - classD, - conT, - instanceD, - mkName, - newName, - promotedT, - varT, - ) -import qualified Language.Haskell.TH -import Language.Haskell.TH.Datatype.TyVarBndr - ( kindedTV, - mapTVFlag, - specifiedSpec, - tvName, - ) -import Language.Haskell.TH.Syntax (Lift) - -#if MIN_VERSION_template_haskell(2,21,0) -type TyVarBndrVis = Language.Haskell.TH.TyVarBndrVis -#elif MIN_VERSION_template_haskell(2,17,0) -type TyVarBndrVis = Language.Haskell.TH.TyVarBndr () -#else -type TyVarBndrVis = Language.Haskell.TH.TyVarBndr -#endif - --- | Provide unified function types. -class UnifiedFun (mode :: EvalModeTag) where - -- | Get a unified function type. Resolves to t'Grisette.SymPrim.=->' in 'C' - -- mode, and t'Grisette.SymPrim.=~>' in 'S' mode. - type - GetFun mode = - (fun :: Data.Kind.Type -> Data.Kind.Type -> Data.Kind.Type) | fun -> mode - -instance UnifiedFun 'C where - type GetFun 'C = (=->) - -instance UnifiedFun 'S where - type GetFun 'S = (=~>) - --- | The unified function type with 2 arguments. -type GetFun2 mode a b = GetFun mode a b - --- | The unified function type with 3 arguments. -type GetFun3 mode a b c = GetFun mode a (GetFun mode b c) - --- | The unified function type with 4 arguments. -type GetFun4 mode a b c d = GetFun mode a (GetFun mode b (GetFun mode c d)) - --- | The unified function type with 5 arguments. -type GetFun5 mode a b c d e = - GetFun mode a (GetFun mode b (GetFun mode c (GetFun mode d e))) - --- | The unified function type with 6 arguments. -type GetFun6 mode a b c d e f = - GetFun - mode - a - (GetFun mode b (GetFun mode c (GetFun mode d (GetFun mode e f)))) - --- | The unified function type with 7 arguments. -type GetFun7 mode a b c d e f g = - GetFun - mode - a - ( GetFun - mode - b - (GetFun mode c (GetFun mode d (GetFun mode e (GetFun mode f g)))) - ) - --- | The unified function type with 8 arguments. -type GetFun8 mode a b c d e f g h = - GetFun - mode - a - ( GetFun - mode - b - ( GetFun - mode - c - (GetFun mode d (GetFun mode e (GetFun mode f (GetFun mode g h)))) - ) - ) - --- | The constraint for a unified function. -type UnifiedFunConstraint mode a b ca cb sa sb = - ( Eq (GetFun mode a b), - EvalSym (GetFun mode a b), - ExtractSym (GetFun mode a b), - PPrint (GetFun mode a b), - Hashable (GetFun mode a b), - Lift (GetFun mode a b), - Mergeable (GetFun mode a b), - NFData (GetFun mode a b), - Show (GetFun mode a b), - SubstSym (GetFun mode a b), - ToCon (GetFun mode a b) (ca =-> cb), - ToCon (sa =~> sb) (GetFun mode a b), - ToSym (GetFun mode a b) (sa =~> sb), - ToSym (ca =-> cb) (GetFun mode a b), - Function (GetFun mode a b) a b, - Apply (GetFun mode a b), - FunType (GetFun mode a b) ~ (a -> b) - ) - -genInnerUnifiedFunInstance :: - String -> - TyVarBndrVis -> - [Pred] -> - [TyVarBndrVis] -> - [(Type, Type, Type)] -> - DecsQ -genInnerUnifiedFunInstance nm mode preds bndrs tys = do - x <- classD (goPred tys) (mkName nm) (mode : bndrs) [] [] - dc <- - instanceD - (return preds) - (applyTypeList (promotedT 'C : additionalTypes)) - [] - ds <- - instanceD - (return preds) - (applyTypeList (promotedT 'S : additionalTypes)) - [] - return [x, dc, ds] - where - additionalTypes = (varT . tvName) <$> bndrs - applyTypeList = foldl appT (conT (mkName nm)) - goPred :: [(Type, Type, Type)] -> Q [Pred] - goPred [] = fail "Empty list of function types, at least 2." - goPred [_] = return [] - goPred (x : xs) = do - p1 <- pred x xs - pr <- goPred xs - return $ p1 : pr - listTys :: [(Type, Type, Type)] -> Q (Type, Type, Type) - listTys [] = fail "Should not happen" - listTys [(u, c, s)] = return (u, c, s) - listTys ((u, c, s) : xs) = do - (u', c', s') <- listTys xs - return - ( AppT (AppT (AppT (ConT ''GetFun) (VarT $ tvName mode)) u) u', - AppT (AppT (ConT ''(=->)) c) c', - AppT (AppT (ConT ''(=~>)) s) s' - ) - pred (ua, ca, sa) l = do - (ub, cb, sb) <- listTys l - [t| - UnifiedFunConstraint - $(return (VarT $ tvName mode)) - $(return ua) - $(return ub) - $(return ca) - $(return cb) - $(return sa) - $(return sb) - |] - -genOuterUnifiedFunInstance :: - String -> String -> TyVarBndrVis -> [Pred] -> [TyVarBndrVis] -> DecsQ -genOuterUnifiedFunInstance nm innerName mode preds bndrs = do - let bndrs' = mapTVFlag (const specifiedSpec) <$> bndrs - x <- - classD - ( return - [ ForallT bndrs' preds $ - foldl' AppT (ConT $ mkName innerName) $ - VarT . tvName <$> mode : bndrs - ] - ) - (mkName nm) - [mode] - [] - [] - dc <- - instanceD - (return []) - (appT (conT $ mkName nm) (promotedT 'C)) - [] - ds <- - instanceD - (return []) - (appT (conT $ mkName nm) (promotedT 'S)) - [] - return [x, dc, ds] - --- | Generate unified function instance names. -unifiedFunInstanceName :: String -> [TheoryToUnify] -> String -unifiedFunInstanceName prefix theories = - prefix ++ "Fun" ++ (concatMap show theories) - --- | Generate unified function instances. -genUnifiedFunInstance :: String -> [TheoryToUnify] -> DecsQ -genUnifiedFunInstance prefix theories = do - modeName <- newName "mode" - let modeType = VarT modeName - allArgs <- traverse (genArgs modeType) theories - let baseName = unifiedFunInstanceName prefix theories - rinner <- - genInnerUnifiedFunInstance - baseName - (kindedTV modeName (ConT ''EvalModeTag)) - (concatMap (\(_, p, _, _, _) -> p) allArgs) - (concatMap (\(t, _, _, _, _) -> t) allArgs) - ((\(_, _, u, c, s) -> (u, c, s)) <$> allArgs) - router <- - if all (\(bndr, _, _, _, _) -> null bndr) allArgs - then return [] - else - genOuterUnifiedFunInstance - ("All" ++ baseName) - baseName - (kindedTV modeName (ConT ''EvalModeTag)) - (concatMap (\(_, p, _, _, _) -> p) allArgs) - (concatMap (\(t, _, _, _, _) -> t) allArgs) - return $ rinner ++ router - where - genArgs :: - Type -> TheoryToUnify -> Q ([TyVarBndrVis], [Pred], Type, Type, Type) - genArgs mode UBool = - return - ( [], - [], - AppT (ConT ''GetBool) mode, - ConT ''Bool, - ConT ''SymBool - ) - genArgs mode UIntN = do - n <- newName "n" - let nType = VarT n - return - ( [kindedTV n (ConT ''Nat)], - [ AppT (ConT ''KnownNat) nType, - AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType - ], - AppT (AppT (ConT ''GetIntN) mode) nType, - AppT (ConT ''IntN) nType, - AppT (ConT ''SymIntN) nType - ) - genArgs mode UWordN = do - n <- newName "n" - let nType = VarT n - return - ( [kindedTV n (ConT ''Nat)], - [ AppT (ConT ''KnownNat) nType, - AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType - ], - AppT (AppT (ConT ''GetWordN) mode) nType, - AppT (ConT ''WordN) nType, - AppT (ConT ''SymWordN) nType - ) - genArgs mode UInteger = - return - ( [], - [], - AppT (ConT ''GetInteger) mode, - ConT ''Integer, - ConT ''SymInteger - ) - genArgs mode UAlgReal = - return - ( [], - [], - AppT (ConT ''GetAlgReal) mode, - ConT ''AlgReal, - ConT ''SymAlgReal - ) - genArgs mode UFP = do - eb <- newName "eb" - sb <- newName "sb" - let ebType = VarT eb - let sbType = VarT sb - return - ( [kindedTV eb (ConT ''Nat), kindedTV sb (ConT ''Nat)], - [AppT (AppT (ConT ''ValidFP) ebType) sbType], - AppT (AppT (AppT (ConT ''GetFP) mode) ebType) sbType, - AppT (AppT (ConT ''FP) ebType) sbType, - AppT (AppT (ConT ''SymFP) ebType) sbType - ) - genArgs _ UFun {} = fail "UFun cannot be nested." diff --git a/src/Grisette/Unified/Internal/UnifiedInteger.hs b/src/Grisette/Unified/Internal/UnifiedInteger.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedInteger.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedInteger --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedInteger - ( GetInteger, - UnifiedInteger, - ) -where - -import Control.Exception (ArithException) -import Control.Monad.Except (MonadError) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Unified.Internal.Class.UnifiedFromIntegral (UnifiedFromIntegral) -import Grisette.Unified.Internal.Class.UnifiedRep - ( UnifiedConRep (ConType), - UnifiedSymRep (SymType), - ) -import Grisette.Unified.Internal.Class.UnifiedSafeDiv (UnifiedSafeDiv) -import Grisette.Unified.Internal.Class.UnifiedSafeLinearArith - ( UnifiedSafeLinearArith, - ) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) -import Grisette.Unified.Internal.UnifiedPrim (UnifiedBasicPrim) - -class - ( i ~ GetInteger mode, - UnifiedConRep i, - UnifiedSymRep i, - ConType i ~ Integer, - SymType i ~ SymInteger, - UnifiedBasicPrim mode i, - Num i, - forall m. - (UnifiedBranching mode m, MonadError ArithException m) => - UnifiedSafeDiv mode ArithException i m, - forall m. - (UnifiedBranching mode m, MonadError ArithException m) => - UnifiedSafeLinearArith mode ArithException i m, - UnifiedFromIntegral mode i i - ) => - UnifiedIntegerImpl (mode :: EvalModeTag) i - | mode -> i - where - -- | Get a unified Integer type. Resolves to 'Integer' in 'C' mode, and - -- 'SymInteger' in 'S' mode. - type GetInteger mode = int | int -> mode - -instance UnifiedIntegerImpl 'C Integer where - type GetInteger 'C = Integer - -instance UnifiedIntegerImpl 'S SymInteger where - type GetInteger 'S = SymInteger - --- | Evaluation mode with unified 'Integer' type. -class - (UnifiedIntegerImpl mode (GetInteger mode)) => - UnifiedInteger (mode :: EvalModeTag) - -instance UnifiedInteger 'C - -instance UnifiedInteger 'S diff --git a/src/Grisette/Unified/Internal/UnifiedPrim.hs b/src/Grisette/Unified/Internal/UnifiedPrim.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/UnifiedPrim.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} - --- | --- Module : Grisette.Unified.Internal.UnifiedPrim --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.UnifiedPrim - ( UnifiedPrim, - UnifiedBasicPrim, - ) -where - -import Grisette.Internal.SymPrim.SymPrim (Prim) -import Grisette.Unified.Internal.BaseConstraint (ConSymConversion) -import Grisette.Unified.Internal.Class.UnifiedITEOp - ( UnifiedITEOp, - ) -import Grisette.Unified.Internal.Class.UnifiedRep - ( UnifiedConRep (ConType), - UnifiedSymRep (SymType), - ) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable - ( UnifiedSimpleMergeable, - ) -import Grisette.Unified.Internal.Class.UnifiedSolvable (UnifiedSolvable) -import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq) -import Grisette.Unified.Internal.Class.UnifiedSymOrd (UnifiedSymOrd) - --- | A type that is used as a constraint for all the (unified) primitive types --- in Grisette. -type UnifiedPrim mode a = - ( Prim a, - UnifiedITEOp mode a, - UnifiedSymEq mode a, - UnifiedSymOrd mode a - ) - --- | A type that is used as a constraint for all the basic (unified) primitive --- types in Grisette. --- --- 'Grisette.Unified.GetSomeWordN' is not considered as a basic (unified) --- primitive type. -type UnifiedBasicPrim mode a = - ( UnifiedPrim mode a, - UnifiedSimpleMergeable mode a, - UnifiedConRep a, - UnifiedSymRep a, - UnifiedSolvable mode a (ConType a), - ConSymConversion (ConType a) (SymType a) a - ) diff --git a/src/Grisette/Unified/Internal/Util.hs b/src/Grisette/Unified/Internal/Util.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/Util.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Unified.Internal.Util --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.Util (withMode) where - -import Data.Typeable (Typeable, eqT, type (:~:) (Refl)) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (C, S)) - --- | Case analysis on the mode. -withMode :: - forall mode r. - (Typeable mode) => - ((mode ~ 'C) => r) -> - ((mode ~ 'S) => r) -> - r -withMode con sym = case (eqT @mode @'C, eqT @mode @'S) of - (Just Refl, _) -> con - (_, Just Refl) -> sym - _ -> error "impossible" -{-# INLINE withMode #-} diff --git a/src/Grisette/Unified/Lib/Control/Monad.hs b/src/Grisette/Unified/Lib/Control/Monad.hs --- a/src/Grisette/Unified/Lib/Control/Monad.hs +++ b/src/Grisette/Unified/Lib/Control/Monad.hs @@ -555,7 +555,7 @@ -- | 'Control.Monad.<$!>' with 'Grisette.Core.MergingStrategy' knowledge -- propagation. Merging is always strict so we can directly use --- 'Grisette.Unified.Lib.Data.Functor..<$>'. +-- 'Grisette.Internal.Unified.Lib.Data.Functor..<$>'. (.<$!>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b f .<$!> a = f .<$> a diff --git a/src/Grisette/Unified/Lib/Data/Foldable.hs b/src/Grisette/Unified/Lib/Data/Foldable.hs --- a/src/Grisette/Unified/Lib/Data/Foldable.hs +++ b/src/Grisette/Unified/Lib/Data/Foldable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} @@ -54,8 +55,12 @@ ) where -import Control.Monad (MonadPlus) +#if MIN_VERSION_base(4,20,0) +#else import Data.Foldable (Foldable (foldl')) +#endif + +import Control.Monad (MonadPlus) import Grisette.Internal.Core.Data.Class.LogicalOp ( LogicalOp (symNot, (.&&), (.||)), ) @@ -67,6 +72,17 @@ mrgSingle, tryMerge, ) +import Grisette.Internal.Unified.BaseMonad (BaseMonad) +import Grisette.Internal.Unified.Class.UnifiedSymEq (UnifiedSymEq, (.==)) +import Grisette.Internal.Unified.Class.UnifiedSymOrd (mrgMax, mrgMin) +import Grisette.Internal.Unified.UnifiedBool (GetBool) +import Grisette.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>)) +import {-# SOURCE #-} Grisette.Lib.Control.Monad + ( mrgMplus, + mrgMzero, + (.>>), + ) +import Grisette.Lib.Data.Functor (mrgFmap, mrgVoid) import Grisette.Unified ( EvalModeBase, UnifiedBranching, @@ -76,17 +92,6 @@ mrgIf, symIteMerge, ) -import Grisette.Unified.Internal.BaseMonad (BaseMonad) -import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq, (.==)) -import Grisette.Unified.Internal.Class.UnifiedSymOrd (mrgMax, mrgMin) -import Grisette.Unified.Internal.UnifiedBool (GetBool) -import Grisette.Unified.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>)) -import {-# SOURCE #-} Grisette.Unified.Lib.Control.Monad - ( mrgMplus, - mrgMzero, - (.>>), - ) -import Grisette.Unified.Lib.Data.Functor (mrgFmap, mrgVoid) -- | 'Data.Foldable.elem' with symbolic equality. symElem :: 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 @@ -39,7 +39,9 @@ mrgIf, mrgIte1, mrgSingle, + toUnionSym, tryMerge, + unionToCon, ) import Grisette.Internal.Core.Control.Monad.Union ( Union (UAny, UMrg), @@ -242,32 +244,40 @@ ) "u1c" actual .@?= expected, - testCase "ToSym a (Union b)" $ do - let actual = toSym True :: Union SymBool + testCase "ToSym a (Union b) should be done with toUnionSym" $ do + let actual = toUnionSym True :: Union SymBool let expected = mrgSingle (con True) actual @?= expected, + testCase "toUnionSym (Identity a) (Union b)" $ do + let actual = toUnionSym $ Identity True :: Union SymBool + let expected = mrgSingle (con True) + actual @?= expected, + testCase "toUnionSym (Union a) (Union b)" $ do + let actual = toUnionSym (mrgSingle True :: Union Bool) :: Union SymBool + let expected = mrgSingle (con True) + actual @?= expected, testCase "ToSym (Identity a) (Union b)" $ do let actual = toSym $ Identity True :: Union SymBool - let expected = mrgSingle (con True) + let expected = return (con True) actual @?= expected, testCase "ToSym (Union a) (Union b)" $ do let actual = toSym (mrgSingle True :: Union Bool) :: Union SymBool - let expected = mrgSingle (con True) + let expected = return (con True) actual @?= expected, testCase "ToSym (Union Integer) SymInteger" $ do let actual = toSym (mrgIf "a" 1 2 :: Union Integer) let expected = symIte "a" 1 2 :: SymInteger actual @?= expected, testGroup - "ToCon (Union a) b" + "ToCon (Union a) b should be done with unionToCon" [ testCase "Const" $ do let actual = mrgSingle (con True) :: Union SymBool let expected = Just True :: Maybe Bool - toCon actual @?= expected, + unionToCon actual @?= expected, testCase "Not const" $ do let actual = mrgSingle "a" :: Union SymBool let expected = Nothing :: Maybe Bool - toCon actual @?= expected + unionToCon actual @?= expected ], testGroup "ToCon (Union a) (Identity b)" diff --git a/test/Grisette/Core/Data/Class/PPrintTests.hs b/test/Grisette/Core/Data/Class/PPrintTests.hs --- a/test/Grisette/Core/Data/Class/PPrintTests.hs +++ b/test/Grisette/Core/Data/Class/PPrintTests.hs @@ -10,10 +10,27 @@ module Grisette.Core.Data.Class.PPrintTests (pprintTests) where +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter + ( PageWidth(AvailablePerLine, Unbounded), + layoutPretty, + LayoutOptions(LayoutOptions), + ) +import Prettyprinter.Render.Text (renderStrict) +#else +import Data.Text.Prettyprint.Doc + ( PageWidth(AvailablePerLine, Unbounded), + layoutPretty, + LayoutOptions(LayoutOptions), + ) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +#endif + import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.Identity (Identity (Identity), IdentityT (IdentityT)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import Data.Int (Int16, Int32, Int64, Int8) @@ -45,22 +62,6 @@ import Test.HUnit ((@?=)) import Test.QuickCheck (Arbitrary (arbitrary), Gen, forAll, oneof) -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter - ( PageWidth(AvailablePerLine, Unbounded), - layoutPretty, - LayoutOptions(LayoutOptions), - ) -import Prettyprinter.Render.Text (renderStrict) -#else -import Data.Text.Prettyprint.Doc - ( PageWidth(AvailablePerLine, Unbounded), - layoutPretty, - LayoutOptions(LayoutOptions), - ) -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) -#endif - testPPrint :: (HasCallStack, PPrint a) => String -> Int -> a -> T.Text -> Test testPPrint n i a s = testCase n $ pformatTextWithWidth i a @?= s @@ -700,24 +701,30 @@ 0 (Identity $ Just $ Just 1 :: Identity (Maybe (Maybe Int))) "Just (Just 1)", - propertyPFormatRead + testPPrint1 "Maybe (MaybeT Maybe Int)" - (Just . MaybeT <$> arbitrary :: Gen (Maybe (MaybeT Maybe Int))), + 0 + (Just $ MaybeT (Just (Just 1)) :: Maybe (MaybeT Maybe Int)) + "Just (MaybeT {runMaybeT = Just (Just 1)})", propertyPFormatRead "Maybe (ExceptT Int Maybe Int)" ( Just . ExceptT <$> arbitrary :: Gen (Maybe (ExceptT Int Maybe Int)) ), - propertyPFormatRead + testPPrint1 "Maybe (LazyWriterT Int Maybe Int)" - ( Just . WriterLazy.WriterT <$> arbitrary :: - Gen (Maybe (WriterLazy.WriterT Int Maybe Int)) - ), - propertyPFormatRead + 0 + ( Just $ WriterLazy.WriterT (Just (1, 2)) :: + Maybe (WriterLazy.WriterT Int Maybe Int) + ) + "Just (WriterT {runWriterT = Just (1, 2)})", + testPPrint1 "Maybe (StrictWriterT Int Maybe Int)" - ( Just . WriterLazy.WriterT <$> arbitrary :: - Gen (Maybe (WriterLazy.WriterT Int Maybe Int)) - ), + 0 + ( Just $ WriterStrict.WriterT (Just (1, 2)) :: + Maybe (WriterStrict.WriterT Int Maybe Int) + ) + "Just (WriterT {runWriterT = Just (1, 2)})", propertyPFormatRead "Maybe (IdentityT Maybe Int)" ( Just . IdentityT <$> arbitrary :: diff --git a/test/Grisette/Core/Data/Class/SymEqTests.hs b/test/Grisette/Core/Data/Class/SymEqTests.hs --- a/test/Grisette/Core/Data/Class/SymEqTests.hs +++ b/test/Grisette/Core/Data/Class/SymEqTests.hs @@ -34,10 +34,11 @@ ssymBool, ) import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion, (@?=)) import Test.QuickCheck (ioProperty) data A = A1 | A2 SymBool | A3 SymBool SymBool @@ -46,8 +47,8 @@ concreteSymEqOkProp :: (HasCallStack, SymEq a, Eq a) => (a, a) -> Assertion concreteSymEqOkProp (i, j) = do - i .== j @=? con (i == j) - i ./= j @=? con (i /= j) + i .== j @?= con (i == j) + i ./= j @?= con (i /= j) seqTests :: Test seqTests = @@ -63,25 +64,25 @@ ( \(i, j) -> conBool i .== conBool j - @=? conBool (i == j) + @?= conBool (i == j) ) [(x, y) | x <- bools, y <- bools], testCase "conBool True vs SymBool" $ do - conBool True .== ssymBool "a" @=? ssymBool "a", + conBool True .== ssymBool "a" @?= ssymBool "a", testCase "conBool False vs SymBool" $ do - conBool False .== ssymBool "a" @=? symNot (ssymBool "a"), + conBool False .== ssymBool "a" @?= symNot (ssymBool "a"), testCase "SymBool vs conBool True" $ do - ssymBool "a" .== conBool True @=? ssymBool "a", + ssymBool "a" .== conBool True @?= ssymBool "a", testCase "SymBool vs conBool False" $ do - ssymBool "a" .== conBool False @=? symNot (ssymBool "a"), + ssymBool "a" .== conBool False @?= symNot (ssymBool "a"), testCase "SymBool vs same SymBool" $ do - ssymBool "a" .== ssymBool "a" @=? conBool True, + ssymBool "a" .== ssymBool "a" @?= conBool True, testCase "SymBool vs different SymBool" $ do let SymBool terma = ssymBool "a" SymBool termb = ssymBool "b" ssymBool "a" .== ssymBool "b" - @=? SymBool (pevalEqTerm terma termb) + @?= SymBool (pevalEqTerm terma termb) ], testProperty "Bool" (ioProperty . concreteSymEqOkProp @Bool), testProperty "Integer" (ioProperty . concreteSymEqOkProp @Integer), @@ -105,19 +106,19 @@ [ testCase "Same length 1" $ [ssymBool "a"] .== [ssymBool "b"] - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "Same length 2" $ [ssymBool "a", ssymBool "b"] .== [ssymBool "c", ssymBool "d"] - @=? (ssymBool "a" .== ssymBool "c") + @?= (ssymBool "a" .== ssymBool "c") .&& (ssymBool "b" .== ssymBool "d"), testCase "length 1 vs length 0" $ - [ssymBool "a"] .== [] @=? conBool False, + [ssymBool "a"] .== [] @?= conBool False, testCase "length 1 vs length 2" $ [ssymBool "a"] .== [ssymBool "c", ssymBool "d"] - @=? conBool False + @?= conBool False ] ], testGroup @@ -127,15 +128,15 @@ testGroup "Maybe SymBool" [ testCase "Nothing vs Nothing" $ - (Nothing :: Maybe SymBool) .== Nothing @=? conBool True, + (Nothing :: Maybe SymBool) .== Nothing @?= conBool True, testCase "Just vs Nothing" $ - Just (ssymBool "a") .== Nothing @=? conBool False, + Just (ssymBool "a") .== Nothing @?= conBool False, testCase "Nothing vs Just" $ - Nothing .== Just (ssymBool "a") @=? conBool False, + Nothing .== Just (ssymBool "a") @?= conBool False, testCase "Just vs Just" $ Just (ssymBool "a") .== Just (ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b" ] ], @@ -148,20 +149,20 @@ [ testCase "Left vs Left" $ (Left (ssymBool "a") :: Either SymBool SymBool) .== Left (ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "Right vs Left" $ (Right (ssymBool "a") :: Either SymBool SymBool) .== Left (ssymBool "b") - @=? conBool False, + @?= conBool False, testCase "Left vs Right" $ (Left (ssymBool "a") :: Either SymBool SymBool) .== Right (ssymBool "b") - @=? conBool False, + @?= conBool False, testCase "Right vs Right" $ (Right (ssymBool "a") :: Either SymBool SymBool) .== Right (ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b" ] ], @@ -176,43 +177,43 @@ [ testCase "MaybeT Nothing vs MaybeT Nothing" $ (MaybeT Nothing :: MaybeT Maybe SymBool) .== MaybeT Nothing - @=? conBool True, + @?= conBool True, testCase "MaybeT Nothing vs MaybeT (Just Nothing)" $ (MaybeT Nothing :: MaybeT Maybe SymBool) .== MaybeT (Just Nothing) - @=? conBool False, + @?= conBool False, testCase "MaybeT Nothing vs MaybeT (Just (Just v))" $ (MaybeT Nothing :: MaybeT Maybe SymBool) .== MaybeT (Just (Just (ssymBool "a"))) - @=? conBool False, + @?= conBool False, testCase "MaybeT (Just Nothing) vs MaybeT Nothing" $ MaybeT (Just Nothing) .== (MaybeT Nothing :: MaybeT Maybe SymBool) - @=? conBool False, + @?= conBool False, testCase "MaybeT (Just (Just v)) vs MaybeT Nothing" $ MaybeT (Just (Just (ssymBool "a"))) .== (MaybeT Nothing :: MaybeT Maybe SymBool) - @=? conBool False, + @?= conBool False, testCase "MaybeT (Just Nothing) vs MaybeT (Just Nothing)" $ MaybeT (Just Nothing) .== (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) - @=? conBool True, + @?= conBool True, testCase "MaybeT (Just (Just v)) vs MaybeT (Just Nothing)" $ MaybeT (Just (Just (ssymBool "a"))) .== (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) - @=? conBool False, + @?= conBool False, testCase "MaybeT (Just Nothing) vs MaybeT (Just (Just v))" $ MaybeT (Just Nothing) .== ( MaybeT (Just (Just (ssymBool "b"))) :: MaybeT Maybe SymBool ) - @=? conBool False, + @?= conBool False, testCase "MaybeT (Just (Just v)) vs MaybeT (Just (Just v))" $ MaybeT (Just (Just (ssymBool "a"))) .== ( MaybeT (Just (Just (ssymBool "b"))) :: MaybeT Maybe SymBool ) - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b" ] ], @@ -227,30 +228,30 @@ [ testCase "ExceptT Nothing vs ExceptT Nothing" $ (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) .== ExceptT Nothing - @=? conBool True, + @?= conBool True, testCase "ExceptT Nothing vs ExceptT (Just (Left v))" $ (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) .== ExceptT (Just (Left (ssymBool "a"))) - @=? conBool False, + @?= conBool False, testCase "ExceptT Nothing vs ExceptT (Just (Right v))" $ (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) .== ExceptT (Just (Right (ssymBool "a"))) - @=? conBool False, + @?= conBool False, testCase "ExceptT (Just (Left v)) vs ExceptT Nothing" $ ExceptT (Just (Left (ssymBool "a"))) .== (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @=? conBool False, + @?= conBool False, testCase "ExceptT (Just (Right v)) vs ExceptT Nothing" $ ExceptT (Just (Right (ssymBool "a"))) .== (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @=? conBool False, + @?= conBool False, testCase "ExceptT (Just (Left v)) vs ExceptT (Just (Left v))" $ ExceptT (Just (Left (ssymBool "a"))) .== ( ExceptT (Just (Left (ssymBool "b"))) :: ExceptT SymBool Maybe SymBool ) - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "ExceptT (Just (Right v)) vs ExceptT (Just (Left v))" @@ -258,21 +259,21 @@ .== ( ExceptT (Just (Left (ssymBool "b"))) :: ExceptT SymBool Maybe SymBool ) - @=? conBool False, + @?= conBool False, testCase "ExceptT (Just (Left v)) vs ExceptT (Just (Right v))" $ ExceptT (Just (Left (ssymBool "a"))) .== ( ExceptT (Just (Right (ssymBool "b"))) :: ExceptT SymBool Maybe SymBool ) - @=? conBool False, + @?= conBool False, testCase "ExceptT (Just (Right v)) vs ExceptT (Just (Right v))" $ ExceptT (Just (Right (ssymBool "a"))) .== ( ExceptT (Just (Right (ssymBool "b"))) :: ExceptT SymBool Maybe SymBool ) - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b" ] ], @@ -284,7 +285,7 @@ testCase "(SymBool, SymBool)" $ do (ssymBool "a", ssymBool "c") .== (ssymBool "b", ssymBool "d") - @=? ssymBool "a" + .@?= ssymBool "a" .== ssymBool "b" .&& ssymBool "c" .== ssymBool "d" @@ -296,7 +297,7 @@ testCase "(SymBool, SymBool, SymBool)" $ (ssymBool "a", ssymBool "c", ssymBool "e") .== (ssymBool "b", ssymBool "d", ssymBool "f") - @=? (ssymBool "a" .== ssymBool "b") + .@?= (ssymBool "a" .== ssymBool "b") .&& ( (ssymBool "c" .== ssymBool "d") .&& (ssymBool "e" .== ssymBool "f") ) @@ -310,9 +311,9 @@ testCase "(SymBool, SymBool, SymBool, SymBool)" $ do (ssymBool "a", ssymBool "c", ssymBool "e", ssymBool "g") .== (ssymBool "b", ssymBool "d", ssymBool "f", ssymBool "h") - @=? ( (ssymBool "a" .== ssymBool "b") - .&& (ssymBool "c" .== ssymBool "d") - ) + .@?= ( (ssymBool "a" .== ssymBool "b") + .&& (ssymBool "c" .== ssymBool "d") + ) .&& ( (ssymBool "e" .== ssymBool "f") .&& (ssymBool "g" .== ssymBool "h") ) @@ -337,9 +338,9 @@ ssymBool "h", ssymBool "j" ) - @=? ( (ssymBool "a" .== ssymBool "b") - .&& (ssymBool "c" .== ssymBool "d") - ) + .@?= ( (ssymBool "a" .== ssymBool "b") + .&& (ssymBool "c" .== ssymBool "d") + ) .&& ( (ssymBool "e" .== ssymBool "f") .&& ( (ssymBool "g" .== ssymBool "h") .&& (ssymBool "i" .== ssymBool "j") @@ -375,11 +376,11 @@ ssymBool "j", ssymBool "l" ) - @=? ( (ssymBool "a" .== ssymBool "b") - .&& ( (ssymBool "c" .== ssymBool "d") - .&& (ssymBool "e" .== ssymBool "f") - ) - ) + .@?= ( (ssymBool "a" .== ssymBool "b") + .&& ( (ssymBool "c" .== ssymBool "d") + .&& (ssymBool "e" .== ssymBool "f") + ) + ) .&& ( (ssymBool "g" .== ssymBool "h") .&& ( (ssymBool "i" .== ssymBool "j") .&& (ssymBool "k" .== ssymBool "l") @@ -419,11 +420,11 @@ ssymBool "l", ssymBool "n" ) - @=? ( (ssymBool "a" .== ssymBool "b") - .&& ( (ssymBool "c" .== ssymBool "d") - .&& (ssymBool "e" .== ssymBool "f") - ) - ) + .@?= ( (ssymBool "a" .== ssymBool "b") + .&& ( (ssymBool "c" .== ssymBool "d") + .&& (ssymBool "e" .== ssymBool "f") + ) + ) .&& ( ( (ssymBool "g" .== ssymBool "h") .&& (ssymBool "i" .== ssymBool "j") ) @@ -467,13 +468,13 @@ ssymBool "n", ssymBool "p" ) - @=? ( ( (ssymBool "a" .== ssymBool "b") - .&& (ssymBool "c" .== ssymBool "d") - ) - .&& ( (ssymBool "e" .== ssymBool "f") - .&& (ssymBool "g" .== ssymBool "h") - ) - ) + .@?= ( ( (ssymBool "a" .== ssymBool "b") + .&& (ssymBool "c" .== ssymBool "d") + ) + .&& ( (ssymBool "e" .== ssymBool "f") + .&& (ssymBool "g" .== ssymBool "h") + ) + ) .&& ( ( (ssymBool "i" .== ssymBool "j") .&& (ssymBool "k" .== ssymBool "l") ) @@ -485,7 +486,7 @@ testCase "ByteString" $ do let bytestrings :: [B.ByteString] = ["", "a", "ab"] traverse_ - (\(i, j) -> i .== j @=? conBool (i == j)) + (\(i, j) -> i .== j @?= conBool (i == j)) [(x, y) | x <- bytestrings, y <- bytestrings], testGroup "Sum" @@ -504,21 +505,21 @@ [ testCase "InL (Just v) vs InL (Just v)" $ (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) .== InL (Just $ ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "InL (Just v) vs InR (Just v)" $ (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) .== InR (Just $ ssymBool "b") - @=? conBool False, + @?= conBool False, testCase "InR (Just v) vs InR (Just v)" $ (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) .== InR (Just $ ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "InR (Just v) vs InL (Just v)" $ (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) .== InL (Just $ ssymBool "b") - @=? conBool False + @?= conBool False ] ], testGroup @@ -543,7 +544,7 @@ WriterLazy.WriterT SymBool (Either SymBool) SymBool ) .== WriterLazy.WriterT (Left $ ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "WriterT (Left v) vs WriterT (Right v)" $ ( WriterLazy.WriterT (Left $ ssymBool "a") :: @@ -551,14 +552,14 @@ ) .== WriterLazy.WriterT (Right (ssymBool "b", ssymBool "c")) - @=? conBool False, + @?= conBool False, testCase "WriterT (Right v) vs WriterT (Left v)" $ ( WriterLazy.WriterT (Right (ssymBool "b", ssymBool "c")) :: WriterLazy.WriterT SymBool (Either SymBool) SymBool ) .== WriterLazy.WriterT (Left $ ssymBool "a") - @=? conBool False, + @?= conBool False, testCase "WriterT (Right v) vs WriterT (Right v)" $ ( WriterLazy.WriterT (Right (ssymBool "a", ssymBool "b")) :: @@ -566,7 +567,7 @@ ) .== WriterLazy.WriterT (Right (ssymBool "c", ssymBool "d")) - @=? (ssymBool "a" .== ssymBool "c") + @?= (ssymBool "a" .== ssymBool "c") .&& (ssymBool "b" .== ssymBool "d") ] ], @@ -593,7 +594,7 @@ SymBool ) .== WriterStrict.WriterT (Left $ ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "WriterT (Left v) vs WriterT (Right v)" $ ( WriterStrict.WriterT (Left $ ssymBool "a") :: @@ -604,7 +605,7 @@ ) .== WriterStrict.WriterT (Right (ssymBool "b", ssymBool "c")) - @=? conBool False, + @?= conBool False, testCase "WriterT (Right v) vs WriterT (Left v)" $ ( WriterStrict.WriterT (Right (ssymBool "b", ssymBool "c")) :: @@ -614,7 +615,7 @@ SymBool ) .== WriterStrict.WriterT (Left $ ssymBool "a") - @=? conBool False, + @?= conBool False, testCase "WriterT (Right v) vs WriterT (Right v)" $ ( WriterStrict.WriterT (Right (ssymBool "a", ssymBool "b")) :: @@ -625,7 +626,7 @@ ) .== WriterStrict.WriterT (Right (ssymBool "c", ssymBool "d")) - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "c" .&& ssymBool "b" .== ssymBool "d" @@ -642,7 +643,7 @@ testCase "Identity SymBool" $ do (Identity $ ssymBool "a" :: Identity SymBool) .== Identity (ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b" ], testGroup @@ -659,26 +660,26 @@ IdentityT (Either SymBool) SymBool ) .== IdentityT (Left $ ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "IdentityT (Left v) vs IdentityT (Right v)" $ ( IdentityT $ Left $ ssymBool "a" :: IdentityT (Either SymBool) SymBool ) .== IdentityT (Right $ ssymBool "b") - @=? conBool False, + @?= conBool False, testCase "IdentityT (Right v) vs IdentityT (Left v)" $ ( IdentityT $ Right $ ssymBool "a" :: IdentityT (Either SymBool) SymBool ) .== IdentityT (Left $ ssymBool "b") - @=? conBool False, + @?= conBool False, testCase "IdentityT (Right v) vs IdentityT (Right v)" $ ( IdentityT $ Right $ ssymBool "a" :: IdentityT (Either SymBool) SymBool ) .== IdentityT (Right $ ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b" ] ] @@ -688,32 +689,32 @@ [ testGroup "Simple ADT" [ testCase "A1 vs A1" $ - A1 .== A1 @=? conBool True, + A1 .== A1 @?= conBool True, testCase "A1 vs A2" $ - A1 .== A2 (ssymBool "a") @=? conBool False, + A1 .== A2 (ssymBool "a") @?= conBool False, testCase "A1 vs A3" $ - A1 .== A3 (ssymBool "a") (ssymBool "b") @=? conBool False, + A1 .== A3 (ssymBool "a") (ssymBool "b") @?= conBool False, testCase "A2 vs A1" $ - A2 (ssymBool "a") .== A1 @=? conBool False, + A2 (ssymBool "a") .== A1 @?= conBool False, testCase "A2 vs A2" $ A2 (ssymBool "a") .== A2 (ssymBool "b") - @=? ssymBool "a" + @?= ssymBool "a" .== ssymBool "b", testCase "A2 vs A3" $ A2 (ssymBool "a") .== A3 (ssymBool "b") (ssymBool "c") - @=? conBool False, + @?= conBool False, testCase "A3 vs A1" $ - A3 (ssymBool "a") (ssymBool "b") .== A1 @=? conBool False, + A3 (ssymBool "a") (ssymBool "b") .== A1 @?= conBool False, testCase "A3 vs A2" $ A3 (ssymBool "a") (ssymBool "b") .== A2 (ssymBool "c") - @=? conBool False, + @?= conBool False, testCase "A3 vs A3" $ A3 (ssymBool "a") (ssymBool "b") .== A3 (ssymBool "c") (ssymBool "d") - @=? (ssymBool "a" .== ssymBool "c") + @?= (ssymBool "a" .== ssymBool "c") .&& (ssymBool "b" .== ssymBool "d") ] ] diff --git a/test/Grisette/Core/Data/Class/SymOrdTests.hs b/test/Grisette/Core/Data/Class/SymOrdTests.hs --- a/test/Grisette/Core/Data/Class/SymOrdTests.hs +++ b/test/Grisette/Core/Data/Class/SymOrdTests.hs @@ -71,14 +71,14 @@ l .> r .@?= ((ll .> rl) .|| ((ll .== rl) .&& (lr .> rr))) l `symCompare` r - @?= ( ( do - lc <- symCompare ll rl - case lc of - EQ -> symCompare lr rr - _ -> mrgReturn lc - ) :: - Union Ordering - ) + .@?= ( ( do + lc <- symCompare ll rl + case lc of + EQ -> symCompare lr rr + _ -> mrgReturn lc + ) :: + Union Ordering + ) sordTests :: Test sordTests = diff --git a/test/Grisette/Core/Data/Class/ToSymTests.hs b/test/Grisette/Core/Data/Class/ToSymTests.hs --- a/test/Grisette/Core/Data/Class/ToSymTests.hs +++ b/test/Grisette/Core/Data/Class/ToSymTests.hs @@ -24,7 +24,6 @@ import Grisette ( ITEOp (symIte), LogicalOp (symNot, (.&&), (.||)), - Mergeable, Solvable (con, isym, ssym), SymBool, SymEq ((.==)), @@ -36,8 +35,7 @@ import Test.HUnit (Assertion, (@?=)) import Test.QuickCheck (ioProperty) -toSymForConcreteOkProp :: - (HasCallStack, Show v, Eq v, Mergeable v) => v -> Assertion +toSymForConcreteOkProp :: (HasCallStack, Show v, Eq v) => v -> Assertion toSymForConcreteOkProp v = toSym v @?= v toSymTests :: Test diff --git a/test/Grisette/Core/TH/DerivationData.hs b/test/Grisette/Core/TH/DerivationData.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/TH/DerivationData.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=derivation #-} + +module Grisette.Core.TH.DerivationData + ( T (..), + concreteT, + symbolicT, + IdenticalFields (..), + Basic (..), + GGG (..), + VVV (..), + Extra (..), + Ambiguous (..), + replaceVVVShown, + gggToVVV, + ) +where + +import Control.DeepSeq (NFData, NFData1, NFData2) +import Control.Monad.Identity (Identity (Identity)) +import Data.Functor.Classes + ( Eq1 (liftEq), + Eq2, + Ord1, + Ord2, + Show1, + Show2, + ) +import Data.Hashable (Hashable) +import Data.Hashable.Lifted (Hashable1, Hashable2) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Typeable (Proxy, Typeable) +import GHC.Generics (Generic) +import Grisette + ( AllSyms, + AllSyms1, + AllSyms2, + BasicSymPrim, + Default (Default), + EvalSym, + EvalSym1, + EvalSym2, + ExtractSym, + ExtractSym1, + ExtractSym2, + Mergeable, + Mergeable1, + Mergeable2, + PPrint, + PPrint1, + PPrint2, + SimpleMergeable, + SubstSym, + SubstSym1, + SubstSym2, + SymBool, + SymEq, + SymEq1, + SymEq2, + SymInteger, + SymOrd, + SymOrd1, + SymOrd2, + ToCon (toCon), + ToSym (toSym), + Union, + allClasses0, + allClasses012, + deriveGADT, + deriveGADTWith, + ) +import Grisette.Core.TH.PartialEvalMode (PartialEvalMode) +import Grisette.Internal.TH.GADT.Common + ( DeriveConfig + ( bitSizePositions, + evalModeConfig, + fpBitSizePositions, + needExtraMergeableUnderEvalMode + ), + EvalModeConfig (EvalModeConstraints), + ) +import Grisette.Unified + ( EvalModeBV, + EvalModeBase, + EvalModeTag (C, S), + GetBool, + GetData, + GetFP, + GetWordN, + UnifiedSimpleMergeable, + ) +import Test.QuickCheck (Arbitrary, oneof) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) + +data T mode n a + = T (GetBool mode) [GetWordN mode n] [a] (GetData mode (T mode n a)) + | TNil + +#if MIN_VERSION_base(4,16,0) +deriveGADTWith + ( mempty + { evalModeConfig = + [(0, EvalModeConstraints [''EvalModeBV, ''EvalModeBase])], + bitSizePositions = [1], + needExtraMergeableUnderEvalMode = True + } + ) + [''T] + allClasses0 + +concreteT :: T 'C 10 Integer +concreteT = + toSym (T True [10] [10 :: Integer] (Identity TNil) :: T 'C 10 Integer) + +symbolicT :: T 'S 10 SymInteger +symbolicT = fromJust $ toCon (toSym concreteT :: T 'S 10 SymInteger) +#else +concreteT :: T 'C 10 Integer +concreteT = undefined + +symbolicT :: T 'S 10 SymInteger +symbolicT = undefined +#endif + +newtype X mode = X [GetBool mode] + +deriveGADTWith + ( mempty + { evalModeConfig = [(0, EvalModeConstraints [''EvalModeBase])] + } + ) + [''X] + allClasses0 + +data IdenticalFields (mode :: EvalModeTag) a b = IdenticalFields + { a :: a, + b :: a, + c :: Maybe Int, + d :: Maybe Int + } + +deriveGADTWith + ( mempty + { needExtraMergeableUnderEvalMode = True + } + ) + [''IdenticalFields] + allClasses012 + +data Basic = Basic0 | Basic1 Int | Basic2 String [Int] + +deriveGADT [''Basic] allClasses0 + +data Extra mode n eb sb a where + Extra :: + GetBool mode -> + [GetWordN mode n] -> + [GetData mode [Extra mode n eb sb a]] -> + GetFP mode eb sb -> + GetFP mode eb sb -> + a -> + a -> + Extra mode n eb sb a + +#if MIN_VERSION_base(4,16,0) +deriveGADTWith + ( mempty + { evalModeConfig = [(0, EvalModeConstraints [''PartialEvalMode])], + bitSizePositions = [1], + fpBitSizePositions = [(2, 3)], + needExtraMergeableUnderEvalMode = True + } + ) + [''Extra] + allClasses0 +#endif + +data Expr f a where + I :: SymInteger -> Expr f SymInteger + B :: SymBool -> Expr f SymBool + Add :: Union (Expr f SymInteger) -> Union (Expr f SymInteger) -> Expr f SymInteger + Mul :: Union (Expr f SymInteger) -> Union (Expr f SymInteger) -> Expr f SymInteger + Eq :: (BasicSymPrim a) => Union (Expr f a) -> Union (Expr f a) -> Expr f SymBool + Eq3 :: + (BasicSymPrim a) => + Union (Expr f a) -> + Union (Expr f a) -> + Union (Expr f b) -> + Union (Expr f b) -> + Expr f b + WExpr :: + (BasicSymPrim a, BasicSymPrim b, BasicSymPrim c) => + a -> + b -> + c -> + d -> + Expr f d + XExpr :: f a -> Expr f a + YExpr :: (BasicSymPrim a) => f a -> Expr f (f a) + ZExpr :: + ( AllSyms1 f, + Mergeable1 f, + Eq1 f, + EvalSym1 f, + ExtractSym1 f, + SubstSym1 f, + NFData1 f, + PPrint1 f, + Show1 f, + Typeable f, + Hashable1 f, + BasicSymPrim a, + SymEq1 f, + SymOrd1 f + ) => + f a -> + Expr g b + +deriveGADT + [''Expr] + [ ''Mergeable, + ''Mergeable1, + ''EvalSym, + ''EvalSym1, + ''ExtractSym, + ''ExtractSym1, + ''SubstSym, + ''SubstSym1, + ''NFData, + ''NFData1, + ''Show, + ''Show1, + ''PPrint, + ''PPrint1, + ''AllSyms, + ''AllSyms1, + ''Eq, + ''SymEq, + ''SymOrd + ] + +instance (Eq1 f) => Eq1 (Expr f) where + liftEq = undefined + +deriveGADT [''Expr] [''Hashable, ''Hashable1] + +data P a b = P a | Q Int + +deriveGADT + [''P] + [ ''Mergeable, + ''Mergeable1, + ''Mergeable2, + ''EvalSym, + ''EvalSym1, + ''EvalSym2, + ''ExtractSym, + ''ExtractSym1, + ''ExtractSym2, + ''SubstSym, + ''SubstSym1, + ''SubstSym2, + ''NFData, + ''NFData1, + ''NFData2, + ''Hashable, + ''Hashable1, + ''Hashable2, + ''Show, + ''Show1, + ''Show2, + ''PPrint, + ''PPrint1, + ''PPrint2, + ''AllSyms, + ''AllSyms1, + ''AllSyms2, + ''Eq, + ''Eq1, + ''Eq2, + ''SymEq, + ''SymEq1, + ''SymEq2, + ''Ord, + ''Ord1, + ''Ord2, + ''SymOrd, + ''SymOrd1, + ''SymOrd2 + ] + +data GGG a b where + GGG2 :: a -> b -> GGG a b + GGG1 :: a -> GGG a b + GGG0 :: GGG a b + GGGRec :: a -> b -> GGG a b + (:|) :: a -> b -> GGG a b + GGGLst :: [a] -> [b] -> GGG a b + +infixr 5 :| + +deriveGADT + [''GGG] + [ ''Show, + ''Show1, + ''Show2, + ''PPrint, + ''PPrint1, + ''PPrint2, + ''Eq, + ''Eq1, + ''Eq2, + ''Ord, + ''Ord1, + ''Ord2, + ''SymEq, + ''SymEq1, + ''SymEq2, + ''SymOrd, + ''SymOrd1, + ''SymOrd2 + ] + +instance (Arbitrary a, Arbitrary b) => Arbitrary (GGG a b) where + arbitrary = + oneof + [ GGG2 <$> arbitrary <*> arbitrary, + GGG1 <$> arbitrary, + return GGG0, + GGGRec <$> arbitrary <*> arbitrary, + (:|) <$> arbitrary <*> arbitrary, + GGGLst <$> arbitrary <*> arbitrary + ] + +gggToVVV :: GGG a b -> VVV a b +gggToVVV (GGG2 a b) = VVV2 a b +gggToVVV (GGG1 a) = VVV1 a +gggToVVV GGG0 = VVV0 +gggToVVV (GGGRec a b) = VVVRec a b +gggToVVV (a :| b) = a :. b +gggToVVV (GGGLst a b) = VVVLst a b + +data VVV a b where + VVV2 :: a -> b -> VVV a b + VVV1 :: a -> VVV a b + VVV0 :: VVV a b + VVVRec :: a -> b -> VVV a b + (:.) :: a -> b -> VVV a b + VVVLst :: [a] -> [b] -> VVV a b + deriving (Generic, Eq, Ord) + deriving (PPrint, SymEq, SymOrd) via (Default (VVV a b)) + +infixr 5 :. + +instance (Arbitrary a, Arbitrary b) => Arbitrary (VVV a b) where + arbitrary = + oneof + [ VVV2 <$> arbitrary <*> arbitrary, + VVV1 <$> arbitrary, + return VVV0, + VVVRec <$> arbitrary <*> arbitrary, + (:.) <$> arbitrary <*> arbitrary + ] + +replaceVVVShown :: T.Text -> T.Text +replaceVVVShown = + T.replace ":." ":|" . T.replace "VVV" "GGG" . T.replace "vvv" "ggg" + +deriving instance (Show a, Show b) => Show (VVV a b) + +data Ambiguous x where + Ambiguous :: forall x a. (BasicSymPrim a) => Proxy a -> Ambiguous x + +instance Eq (Ambiguous x) where + (==) = undefined + +deriveGADT + [''Ambiguous] + [ ''AllSyms, + ''Mergeable, + ''ExtractSym, + ''NFData, + ''PPrint, + ''Show, + ''Hashable + ] + +data SimpleMergeableType mode n x + = SimpleMergeableType + (GetBool mode) + (GetWordN mode n) + x + (GetData mode (SimpleMergeableType mode n x)) + +#if MIN_VERSION_base(4,16,0) +deriveGADTWith + ( mempty + { evalModeConfig = + [(0, EvalModeConstraints [''EvalModeBV, ''EvalModeBase])], + bitSizePositions = [1], + needExtraMergeableUnderEvalMode = True + } + ) + [''SimpleMergeableType] + ([''SimpleMergeable, ''UnifiedSimpleMergeable] ++ allClasses0) +#endif diff --git a/test/Grisette/Core/TH/DerivationTest.hs b/test/Grisette/Core/TH/DerivationTest.hs --- a/test/Grisette/Core/TH/DerivationTest.hs +++ b/test/Grisette/Core/TH/DerivationTest.hs @@ -1,110 +1,160 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -module Grisette.Core.TH.DerivationTest (concreteT, symbolicT) where +{-# HLINT ignore "Unused LANGUAGE pragma" #-} -import Control.Monad.Identity (Identity (Identity)) -import Data.Maybe (fromJust) -import Data.Typeable (Typeable) +-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques #-} +-- {-# OPTIONS_GHC -ddump-timings #-} + +module Grisette.Core.TH.DerivationTest (derivationTest) where + +import Data.Functor.Classes (showsPrec1, showsPrec2) +import qualified Data.Text as T +import GHC.TypeLits (KnownNat, type (<=)) import Grisette - ( BasicSymPrim, - Default (Default), - EvalSym, - EvalSym1, - EvalSym2, - ExtractSym, - ExtractSym1, - ExtractSym2, + ( FP32, Mergeable, - Mergeable1, - Mergeable2, - SymBool, - SymInteger, - ToCon (toCon), - ToSym (toSym), - Union, - deriveAll, - deriveGADT, + PPrint (pformat, pformatPrec), + Solvable (con), + SymEq ((.==)), + SymOrd (symCompare), + ValidFP, + WordN32, + docToTextWithWidth, + mrgSingle, + pformatPrec1, + pformatPrec2, + symCompare1, + symCompare2, + symEq1, + symEq2, ) -import Grisette.Unified (EvalModeTag (C, S), GetBool, GetData, GetWordN) - -data T mode n a - = T (GetBool mode) [GetWordN mode n] [a] (GetData mode (T mode n a)) - | TNil - -deriveAll ''T - -concreteT :: T 'C 10 Integer -concreteT = - toSym (T True [10] [10 :: Integer] (Identity TNil) :: T 'C 10 Integer) - -symbolicT :: T 'S 10 SymInteger -symbolicT = fromJust $ toCon (toSym concreteT :: T 'S 10 SymInteger) - -newtype X mode = X [GetBool mode] - -deriveAll ''X - -data IdenticalFields mode n = IdenticalFields - { a :: n, - b :: n, - c :: Maybe Int, - d :: Maybe Int - } - -deriveAll ''IdenticalFields +import Grisette.Core.TH.DerivationData + ( Extra (Extra), + GGG, + gggToVVV, + replaceVVVShown, + ) +import Grisette.Core.TH.PartialEvalMode (PartialEvalMode) +import Grisette.Unified + ( BaseMonad, + EvalModeTag (C), + GetBool, + GetData, + extractData, + ) +import qualified Grisette.Unified as GU +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@?=)) +import Test.QuickCheck.Property ((.&.), (===)) -data Expr f a where - I :: SymInteger -> Expr f SymInteger - B :: SymBool -> Expr f SymBool - Add :: Union (Expr f SymInteger) -> Union (Expr f SymInteger) -> Expr f SymInteger - Mul :: Union (Expr f SymInteger) -> Union (Expr f SymInteger) -> Expr f SymInteger - Eq :: (BasicSymPrim a, Typeable a) => Union (Expr f a) -> Union (Expr f a) -> Expr f SymBool - Eq3 :: - (BasicSymPrim a, Typeable b) => - Union (Expr f a) -> - Union (Expr f a) -> - Union (Expr f b) -> - Union (Expr f b) -> - Expr f b - XExpr :: f a -> Expr f a +#if MIN_VERSION_base(4,16,0) +ftst :: + forall mode n eb sb a. + ( PartialEvalMode mode, + KnownNat n, + 1 <= n, + ValidFP eb sb, + Mergeable a + ) => + GetBool mode -> + GetData mode (Extra mode n eb sb a) -> + GetData mode (Extra mode n eb sb a) -> + BaseMonad mode (Extra mode n eb sb a) +ftst c t f = + GU.mrgIf @mode + c + (extractData t) + (extractData f) -deriveGADT - ''Expr - [ ''Mergeable, - ''Mergeable1, - ''EvalSym, - ''EvalSym1, - ''ExtractSym, - ''ExtractSym1 +derivationExtraTest :: [Test] +derivationExtraTest = + [ testCase "ftst" $ do + let x = Extra True [1 :: WordN32] [] (0 :: FP32) 0 0 (0 :: Int) + let y = Extra False [1 :: WordN32] [] (0 :: FP32) 0 0 (0 :: Int) + let a = ftst @'C True (return x) (return y) + a @?= return x ] - -data P a b = P a | Q Int +#else +derivationExtraTest :: [Test] +derivationExtraTest = [] +#endif -deriveGADT - ''P - [ ''Mergeable, - ''Mergeable1, - ''Mergeable2, - ''EvalSym, - ''EvalSym1, - ''EvalSym2, - ''ExtractSym, - ''ExtractSym1, - ''ExtractSym2 - ] +derivationTest :: Test +derivationTest = + testGroup "Derivation" $ + [ testProperty "GADT Show instance for regular types" $ + \(g :: GGG (GGG Int String) [Int]) -> + let v = gggToVVV g + in replaceVVVShown (T.pack (show g)) + === replaceVVVShown (T.pack (show v)), + testProperty "GADT Show and Show1 are consistent" $ + \(g :: GGG (GGG Char String) [Int]) -> + T.pack (show g) + === T.pack (showsPrec1 0 g "") + .&. T.pack (showsPrec 11 g "") + === T.pack (showsPrec1 11 g ""), + testProperty "GADT Show and Show2 are consistent" $ + \(g :: GGG (GGG Char String) [Int]) -> + T.pack (show g) + === T.pack (showsPrec2 0 g "") + .&. T.pack (showsPrec 11 g "") + === T.pack (showsPrec2 11 g ""), + testProperty "GADT PPrint instance for regular types" $ + \(g :: GGG (GGG Int String) [Int]) -> + let v = gggToVVV g + in replaceVVVShown (docToTextWithWidth 1000 (pformat g)) + === replaceVVVShown (docToTextWithWidth 1000 (pformat v)) + .&. replaceVVVShown (docToTextWithWidth 0 (pformat g)) + === replaceVVVShown (docToTextWithWidth 0 (pformat v)), + testProperty "GADT PPrint and PPrint1 are consistent" $ + \(g :: GGG (GGG Char String) [Int]) -> + docToTextWithWidth 1000 (pformatPrec 0 g) + === docToTextWithWidth 1000 (pformatPrec1 0 g) + .&. docToTextWithWidth 1000 (pformatPrec 11 g) + === docToTextWithWidth 1000 (pformatPrec1 11 g) + .&. docToTextWithWidth 0 (pformatPrec 0 g) + === docToTextWithWidth 0 (pformatPrec1 0 g) + .&. docToTextWithWidth 0 (pformatPrec 11 g) + === docToTextWithWidth 0 (pformatPrec1 11 g), + testProperty "GADT PPrint and PPrint2 are consistent" $ + \(g :: GGG (GGG Char String) [Int]) -> + docToTextWithWidth 1000 (pformatPrec 0 g) + === docToTextWithWidth 1000 (pformatPrec2 0 g) + .&. docToTextWithWidth 1000 (pformatPrec 11 g) + === docToTextWithWidth 1000 (pformatPrec2 11 g) + .&. docToTextWithWidth 0 (pformatPrec 0 g) + === docToTextWithWidth 0 (pformatPrec2 0 g) + .&. docToTextWithWidth 0 (pformatPrec 11 g) + === docToTextWithWidth 0 (pformatPrec2 11 g), + testProperty "GADT SymEq and Eq are consistent" $ + \(g1 :: GGG (GGG Int String) [Int]) g2 -> + let v1 = gggToVVV g1 + v2 = gggToVVV g2 + in con (g1 == g2) === (v1 .== v2), + testProperty "GADT SymEq1 and SymEq are consistent" $ + \(g1 :: GGG (GGG Int String) [Int]) g2 -> + symEq1 g1 g2 === (g1 .== g2), + testProperty "GADT SymEq2 and SymEq are consistent" $ + \(g1 :: GGG (GGG Int String) [Int]) g2 -> + symEq2 g1 g2 === (g1 .== g2), + testProperty "GADT SymOrd and Ord are consistent" $ + \(g1 :: GGG (GGG Int String) [Int]) g2 -> + let v1 = gggToVVV g1 + v2 = gggToVVV g2 + in mrgSingle (g1 `compare` g2) === (v1 `symCompare` v2), + testProperty "GADT SymOrd1 and SymOrd are consistent" $ + \(g1 :: GGG (GGG Int String) [Int]) g2 -> + symCompare1 g1 g2 === (g1 `symCompare` g2), + testProperty "GADT SymOrd2 and SymOrd are consistent" $ + \(g1 :: GGG (GGG Int String) [Int]) g2 -> + symCompare2 g1 g2 === (g1 `symCompare` g2) + ] + ++ derivationExtraTest diff --git a/test/Grisette/Core/TH/PartialEvalMode.hs b/test/Grisette/Core/TH/PartialEvalMode.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/TH/PartialEvalMode.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Grisette.Core.TH.PartialEvalMode + ( PartialEvalMode, + MonadPartialEvalMode, + ) +where + +import Grisette.Unified + ( TheoryToUnify (UBool, UFP, UWordN), + genEvalMode, + ) + +genEvalMode "PartialEvalMode" [UBool, UWordN, UFP] diff --git a/test/Grisette/SymPrim/FPTests.hs b/test/Grisette/SymPrim/FPTests.hs --- a/test/Grisette/SymPrim/FPTests.hs +++ b/test/Grisette/SymPrim/FPTests.hs @@ -551,7 +551,6 @@ forall (bv :: Nat -> Type) (sbvbv :: Nat -> Type). ( ConvertibleBound bv, Num (bv n), - SBV.HasKind (sbvbv n), SBV.SymVal (sbvbv n), Num (SBV.SBV (sbvbv n)), Typeable bv diff --git a/test/Grisette/Unified/EvalModeTest.hs b/test/Grisette/Unified/EvalModeTest.hs --- a/test/Grisette/Unified/EvalModeTest.hs +++ b/test/Grisette/Unified/EvalModeTest.hs @@ -85,17 +85,17 @@ GetWordN, TheoryToUnify (UFun, UIntN, UWordN), UnifiedBranching, + UnifiedFun (GetFun), extractData, genEvalMode, mrgIte, + safeBitCast, safeDiv, symFromIntegral, symIte, (.<), (.==), ) -import Grisette.Unified.Internal.Class.UnifiedSafeBitCast (safeBitCast) -import Grisette.Unified.Internal.UnifiedFun (UnifiedFun (GetFun)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -258,7 +258,8 @@ ( EvalModeBase mode, EvalModeBV mode, UnifiedData mode (A mode), - UnifiedBV mode 8 + UnifiedBV mode 8, + Mergeable (GetData mode (A mode)) ) #endif @@ -282,7 +283,8 @@ MonadError ArithException m, UnifiedBranching mode m, UnifiedData mode (A mode), - SafeUnifiedBV mode 8 m + SafeUnifiedBV mode 8 m, + Mergeable (GetData mode (A mode)) ) #endif diff --git a/test/Grisette/Unified/UnifiedClassesTest.hs b/test/Grisette/Unified/UnifiedClassesTest.hs --- a/test/Grisette/Unified/UnifiedClassesTest.hs +++ b/test/Grisette/Unified/UnifiedClassesTest.hs @@ -1,20 +1,23 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + module Grisette.Unified.UnifiedClassesTest (unifiedClassesTest) where import Control.Monad.Except (ExceptT, MonadError (throwError)) @@ -22,18 +25,29 @@ import qualified Data.Text as T import GHC.TypeNats (KnownNat, type (<=)) import Grisette - ( Default (Default), + ( Mergeable, SymBool, + SymEq, SymInteger, SymWordN, Union, WordN, + deriveGADTWith, mrgReturn, + symAnd, ) import qualified Grisette -import Grisette.TH (deriveAll) +import Grisette.Internal.TH.GADT.Common + ( DeriveConfig + ( bitSizePositions, + evalModeConfig, + needExtraMergeableUnderEvalMode + ), + EvalModeConfig (EvalModeConstraints), + ) import Grisette.Unified ( BaseMonad, + EvalModeBV, EvalModeBase, EvalModeInteger, GetBool, @@ -41,6 +55,8 @@ GetInteger, GetWordN, UnifiedBranching, + UnifiedSymEq, + UnifiedSymEq1, mrgIf, (.==), ) @@ -70,21 +86,43 @@ testBranchingBase x = mrgIf (x .== 1 :: GetBool mode) (return x) (throwError "err") -data X mode n +data X mode n f a = X (GetBool mode) [GetWordN mode n] - (GetData mode (X mode n)) - [GetData mode (X mode n)] + (GetData mode (X mode n f a)) + [GetData mode (X mode n f a)] + a + (f a) | XNil -deriveAll ''X +#if MIN_VERSION_base(4,16,0) +deriveGADTWith + ( mempty + { evalModeConfig = + [(0, EvalModeConstraints [''EvalModeBV, ''EvalModeBase])], + bitSizePositions = [1], + needExtraMergeableUnderEvalMode = True + } + ) + [''X] + [ ''Mergeable, + ''Eq, + ''SymEq, + ''UnifiedSymEq + ] testSEq :: - forall mode n. - (EvalModeBase mode, 1 <= n, KnownNat n) => - X mode n -> - X mode n -> + forall mode n f a. + ( EvalModeBase mode, + EvalModeBV mode, + 1 <= n, + KnownNat n, + UnifiedSymEq1 mode f, + UnifiedSymEq mode a + ) => + X mode n f a -> + X mode n f a -> GetBool mode testSEq = (.==) @@ -112,13 +150,37 @@ testGroup "UnifiedSEq" [ testCase "testSEq 'Con" $ do - let x1 = X True [1 :: WordN 8] (Identity XNil) [Identity XNil] - let x2 = X False [1 :: WordN 8] (Identity XNil) [Identity XNil] + let x1 = X True [1 :: WordN 8] (Identity XNil) [Identity XNil] (1 :: Integer) [1] + let x2 = X False [1 :: WordN 8] (Identity XNil) [Identity XNil] (1 :: Integer) [2] testSEq x1 x1 @?= True testSEq x1 x2 @?= False, testCase "testSEq 'Sym" $ do - let x1 = X "a" [1 :: SymWordN 8] (mrgReturn XNil) [mrgReturn XNil] - let x2 = X "b" [1 :: SymWordN 8] (mrgReturn XNil) [mrgReturn XNil] - testSEq x1 x2 @?= ("a" :: SymBool) .== "b" + let x1 = + X + "a" + [1 :: SymWordN 8] + (mrgReturn XNil) + [mrgReturn XNil] + ("x" :: SymInteger) + ["w"] + let x2 = + X + "b" + [1 :: SymWordN 8] + (mrgReturn XNil) + [mrgReturn XNil] + ("y" :: SymInteger) + ["z"] + testSEq x1 x2 + @?= symAnd + [ (("a" :: SymBool) .== "b"), + (("x" :: SymInteger) .== "y"), + (("w" :: SymInteger) .== "z") + ] ] ] + +#else +unifiedClassesTest :: Test +unifiedClassesTest = testGroup "UnifiedClasses" [] +#endif diff --git a/test/Grisette/Unified/UnifiedConstructorTest.hs b/test/Grisette/Unified/UnifiedConstructorTest.hs --- a/test/Grisette/Unified/UnifiedConstructorTest.hs +++ b/test/Grisette/Unified/UnifiedConstructorTest.hs @@ -11,28 +11,46 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Grisette.Unified.UnifiedConstructorTest (unifiedConstructorTest) where #if MIN_VERSION_base(4,16,0) -import Grisette.Unified.Internal.UnifiedData (GetData) +import Grisette.Unified (EvalModeBase, EvalModeTag (S), GetBool, GetData) #else -import Grisette.Unified.Internal.UnifiedData (GetData, UnifiedData) +import Grisette.Unified + ( EvalModeBase, + EvalModeTag (S), + GetBool, + GetData, + UnifiedData, + ) #endif import Control.Monad.Identity (Identity (Identity)) -import Generics.Deriving (Default (Default)) -import Grisette (Solvable (con), SymInteger, ToSym (toSym), Union, mrgReturn) -import Grisette.TH (deriveAll, makeNamedUnifiedCtor, makePrefixedUnifiedCtor) -import Grisette.Unified.Internal.EvalMode (EvalModeBase) -import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (S)) -import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette + ( Solvable (con), + SymInteger, + ToSym (toSym), + Union, + allClasses0, + allClasses01, + deriveGADT, + deriveGADTWith, + mrgReturn, + ) +import Grisette.Internal.TH.GADT.Common + ( DeriveConfig (evalModeConfig, needExtraMergeableUnderEvalMode), + EvalModeConfig (EvalModeConstraints), + ) +import Grisette.TH (makeNamedUnifiedCtor, makePrefixedUnifiedCtor) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -41,9 +59,19 @@ = T (GetBool mode) a (GetData mode (T mode a)) | T1 -deriveAll ''T -makePrefixedUnifiedCtor "mk" ''T +#if MIN_VERSION_base(4,16,0) +deriveGADTWith + ( mempty + { evalModeConfig = [(0, EvalModeConstraints [''EvalModeBase])], + needExtraMergeableUnderEvalMode = True + } + ) + [''T] + allClasses0 +makePrefixedUnifiedCtor [''EvalModeBase] "mk" ''T +#endif + #if MIN_VERSION_base(4,16,0) type FConstraint mode = (EvalModeBase mode) #else @@ -51,30 +79,40 @@ (EvalModeBase mode, UnifiedData mode (T mode SymInteger)) #endif +#if MIN_VERSION_base(4,16,0) f :: forall mode. (FConstraint mode) => GetData mode (T mode SymInteger) f = mkT (toSym True) 10 mkT1 +#endif data TNoMode a = TNoMode0 Bool a (TNoMode a) | TNoMode1 -deriveAll ''TNoMode -makeNamedUnifiedCtor ["tNoMode0", "tNoMode1"] ''TNoMode +deriveGADT [''TNoMode] allClasses01 +makeNamedUnifiedCtor [] ["tNoMode0", "tNoMode1"] ''TNoMode data TNoArg = TNoArg -deriveAll ''TNoArg -makePrefixedUnifiedCtor "mk" ''TNoArg +deriveGADT [''TNoArg] allClasses0 +makePrefixedUnifiedCtor [] "mk" ''TNoArg +#if MIN_VERSION_base(4,16,0) +unifiedConstructorExtraTest :: [Test] +unifiedConstructorExtraTest = + [ testCase "mkUnifiedConstructor" $ do + f @?= Identity (T True 10 (Identity T1)) + f + @?= ( mrgReturn (T (con True) 10 (mrgReturn T1)) :: + Union (T 'S SymInteger) + ) + ] +#else +unifiedConstructorExtraTest :: [Test] +unifiedConstructorExtraTest = [] +#endif + unifiedConstructorTest :: Test unifiedConstructorTest = - testGroup - "UnifiedConstructor" - [ testCase "mkUnifiedConstructor" $ do - f @?= Identity (T True 10 (Identity T1)) - f - @?= ( mrgReturn (T (con True) 10 (mrgReturn T1)) :: - Union (T 'S SymInteger) - ), - testCase "NoMode" $ do + testGroup "UnifiedConstructor" $ + [ testCase "NoMode" $ do tNoMode0 True (10 :: Int) TNoMode1 @?= Identity (TNoMode0 True 10 TNoMode1) tNoMode1 @?= (mrgReturn TNoMode1 :: Union (TNoMode Int)), @@ -82,3 +120,4 @@ mkTNoArg @?= Identity TNoArg mkTNoArg @?= (mrgReturn TNoArg :: Union TNoArg) ] + ++ unifiedConstructorExtraTest diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -32,6 +32,7 @@ import Grisette.Core.Data.Class.ToSymTests (toSymTests) import Grisette.Core.Data.Class.TryMergeTests (tryMergeTests) import Grisette.Core.Data.UnionBaseTests (unionBaseTests) +import Grisette.Core.TH.DerivationTest (derivationTest) import Grisette.Lib.Control.ApplicativeTest (applicativeFunctionTests) import Grisette.Lib.Control.Monad.ExceptTests ( monadExceptFunctionTests, @@ -127,7 +128,8 @@ tryMergeTests ], unionBaseTests - ] + ], + testGroup "TH" [derivationTest] ] libTests :: Test