├── .gdbinit ├── .github └── workflows │ ├── hlint.yml │ ├── ormolu.yml │ └── test.yml ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── doctest └── Main.hs ├── examples ├── README.md ├── basic │ └── Main.hs ├── grisette-examples.cabal └── package.yaml ├── flake.lock ├── flake.nix ├── grisette.cabal ├── hie.yaml ├── package.yaml ├── src ├── Grisette.hs └── Grisette │ ├── Backend.hs │ ├── Core.hs │ ├── Experimental.hs │ ├── Experimental │ ├── GenSymConstrained.hs │ ├── MonadParallelUnion.hs │ └── Qualified │ │ └── ParallelUnionDo.hs │ ├── Internal │ ├── Backend │ │ ├── QuantifiedStack.hs │ │ ├── Solving.hs │ │ └── SymBiMap.hs │ ├── Core │ │ ├── Control │ │ │ ├── Exception.hs │ │ │ └── Monad │ │ │ │ ├── CBMCExcept.hs │ │ │ │ ├── Class │ │ │ │ └── Union.hs │ │ │ │ └── Union.hs │ │ └── Data │ │ │ ├── Class │ │ │ ├── AsKey.hs │ │ │ ├── BitCast.hs │ │ │ ├── BitVector.hs │ │ │ ├── CEGISSolver.hs │ │ │ ├── Concrete.hs │ │ │ ├── Error.hs │ │ │ ├── EvalSym.hs │ │ │ ├── ExtractSym.hs │ │ │ ├── Function.hs │ │ │ ├── GenSym.hs │ │ │ ├── IEEEFP.hs │ │ │ ├── ITEOp.hs │ │ │ ├── LogicalOp.hs │ │ │ ├── Mergeable.hs │ │ │ ├── ModelOps.hs │ │ │ ├── PPrint.hs │ │ │ ├── SafeBitCast.hs │ │ │ ├── SafeDiv.hs │ │ │ ├── SafeFdiv.hs │ │ │ ├── SafeFromFP.hs │ │ │ ├── SafeLinearArith.hs │ │ │ ├── SafeLogBase.hs │ │ │ ├── SafeSymRotate.hs │ │ │ ├── SafeSymShift.hs │ │ │ ├── SignConversion.hs │ │ │ ├── SimpleMergeable.hs │ │ │ ├── Solvable.hs │ │ │ ├── Solver.hs │ │ │ ├── SubstSym.hs │ │ │ ├── SymEq.hs │ │ │ ├── SymFiniteBits.hs │ │ │ ├── SymFromIntegral.hs │ │ │ ├── SymIEEEFP.hs │ │ │ ├── SymOrd.hs │ │ │ ├── SymRotate.hs │ │ │ ├── SymShift.hs │ │ │ ├── ToCon.hs │ │ │ ├── ToSym.hs │ │ │ ├── TryMerge.hs │ │ │ └── UnionView.hs │ │ │ ├── MemoUtils.hs │ │ │ ├── SExpr.hs │ │ │ ├── Symbol.hs │ │ │ └── UnionBase.hs │ ├── Internal │ │ ├── Decl │ │ │ ├── Core │ │ │ │ ├── Control │ │ │ │ │ └── Monad │ │ │ │ │ │ └── Union.hs │ │ │ │ └── Data │ │ │ │ │ ├── Class │ │ │ │ │ ├── EvalSym.hs │ │ │ │ │ ├── ExtractSym.hs │ │ │ │ │ ├── Mergeable.hs │ │ │ │ │ ├── PPrint.hs │ │ │ │ │ ├── SafeDiv.hs │ │ │ │ │ ├── SimpleMergeable.hs │ │ │ │ │ ├── Solver.hs │ │ │ │ │ ├── SubstSym.hs │ │ │ │ │ ├── SymEq.hs │ │ │ │ │ ├── SymOrd.hs │ │ │ │ │ ├── ToCon.hs │ │ │ │ │ ├── ToSym.hs │ │ │ │ │ └── TryMerge.hs │ │ │ │ │ └── UnionBase.hs │ │ │ ├── SymPrim │ │ │ │ └── AllSyms.hs │ │ │ └── Unified │ │ │ │ ├── BVFPConversion.hs │ │ │ │ ├── Class │ │ │ │ ├── UnifiedITEOp.hs │ │ │ │ ├── UnifiedSimpleMergeable.hs │ │ │ │ ├── UnifiedSymEq.hs │ │ │ │ └── UnifiedSymOrd.hs │ │ │ │ ├── EvalMode.hs │ │ │ │ ├── FPFPConversion.hs │ │ │ │ ├── UnifiedBV.hs │ │ │ │ ├── UnifiedBool.hs │ │ │ │ └── UnifiedFP.hs │ │ └── Impl │ │ │ ├── Core │ │ │ ├── Control │ │ │ │ └── Monad │ │ │ │ │ └── Union.hs │ │ │ └── Data │ │ │ │ ├── Class │ │ │ │ ├── EvalSym.hs │ │ │ │ ├── ExtractSym.hs │ │ │ │ ├── Mergeable.hs │ │ │ │ ├── PPrint.hs │ │ │ │ ├── SafeDiv.hs │ │ │ │ ├── SimpleMergeable.hs │ │ │ │ ├── Solver.hs │ │ │ │ ├── SubstSym.hs │ │ │ │ ├── SymEq.hs │ │ │ │ ├── SymOrd.hs │ │ │ │ ├── ToCon.hs │ │ │ │ ├── ToSym.hs │ │ │ │ └── TryMerge.hs │ │ │ │ └── UnionBase.hs │ │ │ ├── SymPrim │ │ │ └── AllSyms.hs │ │ │ └── Unified │ │ │ ├── BVFPConversion.hs │ │ │ ├── Class │ │ │ ├── UnifiedITEOp.hs │ │ │ ├── UnifiedSimpleMergeable.hs │ │ │ ├── UnifiedSymEq.hs │ │ │ └── UnifiedSymOrd.hs │ │ │ ├── EvalMode.hs │ │ │ ├── FPFPConversion.hs │ │ │ ├── UnifiedBV.hs │ │ │ ├── UnifiedBool.hs │ │ │ └── UnifiedFP.hs │ ├── SymPrim │ │ ├── AlgReal.hs │ │ ├── AllSyms.hs │ │ ├── BV.hs │ │ ├── FP.hs │ │ ├── FunInstanceGen.hs │ │ ├── GeneralFun.hs │ │ ├── IntBitwidth.hs │ │ ├── ModelRep.hs │ │ ├── Prim │ │ │ ├── Internal │ │ │ │ ├── Caches.hs │ │ │ │ ├── Instances │ │ │ │ │ ├── PEvalBitCastTerm.hs │ │ │ │ │ ├── PEvalDivModIntegralTerm.hs │ │ │ │ │ ├── PEvalFP.hs │ │ │ │ │ ├── PEvalFloatingTerm.hs │ │ │ │ │ ├── PEvalFractionalTerm.hs │ │ │ │ │ ├── PEvalFromIntegralTerm.hs │ │ │ │ │ ├── PEvalIEEEFPConvertibleTerm.hs │ │ │ │ │ ├── PEvalNumTerm.hs │ │ │ │ │ ├── PEvalOrdTerm.hs │ │ │ │ │ ├── PEvalRotateTerm.hs │ │ │ │ │ └── PEvalShiftTerm.hs │ │ │ │ ├── PartialEval.hs │ │ │ │ ├── Serialize.hs │ │ │ │ ├── Term.hs │ │ │ │ ├── Unfold.hs │ │ │ │ └── Utils.hs │ │ │ ├── Model.hs │ │ │ ├── Pattern.hs │ │ │ ├── SomeTerm.hs │ │ │ ├── Term.hs │ │ │ └── TermUtils.hs │ │ ├── Quantifier.hs │ │ ├── SomeBV.hs │ │ ├── SymAlgReal.hs │ │ ├── SymBV.hs │ │ ├── SymBool.hs │ │ ├── SymFP.hs │ │ ├── SymGeneralFun.hs │ │ ├── SymInteger.hs │ │ ├── SymPrim.hs │ │ ├── SymTabularFun.hs │ │ └── TabularFun.hs │ ├── TH │ │ ├── ADT.hs │ │ ├── Ctor │ │ │ ├── Common.hs │ │ │ ├── SmartConstructor.hs │ │ │ └── UnifiedConstructor.hs │ │ ├── Derivation │ │ │ ├── BinaryOpCommon.hs │ │ │ ├── Common.hs │ │ │ ├── ConvertOpCommon.hs │ │ │ ├── Derive.hs │ │ │ ├── DeriveAllSyms.hs │ │ │ ├── DeriveBinary.hs │ │ │ ├── DeriveCereal.hs │ │ │ ├── DeriveEq.hs │ │ │ ├── DeriveEvalSym.hs │ │ │ ├── DeriveExtractSym.hs │ │ │ ├── DeriveHashable.hs │ │ │ ├── DeriveMergeable.hs │ │ │ ├── DeriveNFData.hs │ │ │ ├── DeriveOrd.hs │ │ │ ├── DerivePPrint.hs │ │ │ ├── DeriveSerial.hs │ │ │ ├── DeriveShow.hs │ │ │ ├── DeriveSimpleMergeable.hs │ │ │ ├── DeriveSubstSym.hs │ │ │ ├── DeriveSymEq.hs │ │ │ ├── DeriveSymOrd.hs │ │ │ ├── DeriveToCon.hs │ │ │ ├── DeriveToSym.hs │ │ │ ├── DeriveUnifiedSimpleMergeable.hs │ │ │ ├── DeriveUnifiedSymEq.hs │ │ │ ├── DeriveUnifiedSymOrd.hs │ │ │ ├── SerializeCommon.hs │ │ │ ├── ShowPPrintCommon.hs │ │ │ ├── UnaryOpCommon.hs │ │ │ └── UnifiedOpCommon.hs │ │ └── Util.hs │ ├── Unified │ │ ├── BVBVConversion.hs │ │ ├── BVFPConversion.hs │ │ ├── BaseConstraint.hs │ │ ├── Class │ │ │ ├── UnifiedFiniteBits.hs │ │ │ ├── UnifiedFromIntegral.hs │ │ │ ├── UnifiedITEOp.hs │ │ │ ├── UnifiedRep.hs │ │ │ ├── UnifiedSafeBitCast.hs │ │ │ ├── UnifiedSafeDiv.hs │ │ │ ├── UnifiedSafeFdiv.hs │ │ │ ├── UnifiedSafeFromFP.hs │ │ │ ├── UnifiedSafeLinearArith.hs │ │ │ ├── UnifiedSafeSymRotate.hs │ │ │ ├── UnifiedSafeSymShift.hs │ │ │ ├── UnifiedSimpleMergeable.hs │ │ │ ├── UnifiedSolvable.hs │ │ │ ├── UnifiedSymEq.hs │ │ │ ├── UnifiedSymOrd.hs │ │ │ └── UnionViewMode.hs │ │ ├── EvalMode.hs │ │ ├── EvalModeTag.hs │ │ ├── FPFPConversion.hs │ │ ├── Theories.hs │ │ ├── UnifiedAlgReal.hs │ │ ├── UnifiedBV.hs │ │ ├── UnifiedBool.hs │ │ ├── UnifiedData.hs │ │ ├── UnifiedFP.hs │ │ ├── UnifiedFun.hs │ │ ├── UnifiedInteger.hs │ │ ├── UnifiedPrim.hs │ │ └── Util.hs │ └── Utils │ │ ├── Derive.hs │ │ └── Parameterized.hs │ ├── Lib │ ├── Base.hs │ ├── Control │ │ ├── Applicative.hs │ │ ├── Monad.hs │ │ ├── Monad.hs-boot │ │ └── Monad │ │ │ ├── Except.hs │ │ │ ├── State │ │ │ └── Class.hs │ │ │ ├── Trans.hs │ │ │ └── Trans │ │ │ ├── Class.hs │ │ │ ├── Cont.hs │ │ │ ├── Except.hs │ │ │ ├── State.hs │ │ │ └── State │ │ │ ├── Lazy.hs │ │ │ └── Strict.hs │ └── Data │ │ ├── Bool.hs │ │ ├── Either.hs │ │ ├── Foldable.hs │ │ ├── Functor.hs │ │ ├── Functor │ │ └── Sum.hs │ │ ├── List.hs │ │ ├── Maybe.hs │ │ ├── Traversable.hs │ │ └── Tuple.hs │ ├── SymPrim.hs │ ├── TH.hs │ ├── Unified.hs │ ├── Unified │ └── Lib │ │ ├── Control │ │ ├── Applicative.hs │ │ ├── Monad.hs │ │ └── Monad.hs-boot │ │ └── Data │ │ ├── Foldable.hs │ │ └── Functor.hs │ └── Utils.hs ├── stack-8.10-lowerbound.yaml ├── stack-8.10-lowerbound.yaml.lock ├── stack-8.10.yaml ├── stack-8.10.yaml.lock ├── stack-9.0.yaml ├── stack-9.0.yaml.lock ├── stack-9.10.yaml ├── stack-9.10.yaml.lock ├── stack-9.2.yaml ├── stack-9.2.yaml.lock ├── stack-9.4.yaml ├── stack-9.4.yaml.lock ├── stack-9.6.yaml ├── stack-9.6.yaml.lock ├── stack-9.8.yaml ├── stack-9.8.yaml.lock ├── stack.yaml ├── stack.yaml.lock ├── test ├── Grisette │ ├── Backend │ │ ├── CEGISTests.hs │ │ ├── LoweringTests.hs │ │ ├── TermRewritingGen.hs │ │ └── TermRewritingTests.hs │ ├── Core │ │ ├── Control │ │ │ ├── ExceptionTests.hs │ │ │ └── Monad │ │ │ │ └── UnionTests.hs │ │ ├── Data │ │ │ ├── Class │ │ │ │ ├── BitCastTests.hs │ │ │ │ ├── BoolTests.hs │ │ │ │ ├── EvalSymTests.hs │ │ │ │ ├── ExtractSymTests.hs │ │ │ │ ├── GenSymTests.hs │ │ │ │ ├── MergeableTests.hs │ │ │ │ ├── PPrintTests.hs │ │ │ │ ├── SafeDivTests.hs │ │ │ │ ├── SafeLinearArithTests.hs │ │ │ │ ├── SafeSymRotateTests.hs │ │ │ │ ├── SafeSymShiftTests.hs │ │ │ │ ├── SimpleMergeableTests.hs │ │ │ │ ├── SubstSymTests.hs │ │ │ │ ├── SymEqTests.hs │ │ │ │ ├── SymFiniteBitsTests.hs │ │ │ │ ├── SymOrdTests.hs │ │ │ │ ├── SymRotateTests.hs │ │ │ │ ├── SymShiftTests.hs │ │ │ │ ├── TestValues.hs │ │ │ │ ├── ToConTests.hs │ │ │ │ ├── ToSymTests.hs │ │ │ │ ├── TryMergeTests.hs │ │ │ │ └── UnionViewTests.hs │ │ │ └── UnionBaseTests.hs │ │ └── TH │ │ │ ├── DerivationData.hs │ │ │ ├── DerivationTest.hs │ │ │ └── PartialEvalMode.hs │ ├── Lib │ │ ├── Control │ │ │ ├── ApplicativeTest.hs │ │ │ ├── Monad │ │ │ │ ├── ExceptTests.hs │ │ │ │ ├── State │ │ │ │ │ └── ClassTests.hs │ │ │ │ └── Trans │ │ │ │ │ ├── ClassTests.hs │ │ │ │ │ ├── ExceptTests.hs │ │ │ │ │ └── State │ │ │ │ │ ├── Common.hs │ │ │ │ │ ├── LazyTests.hs │ │ │ │ │ └── StrictTests.hs │ │ │ └── MonadTests.hs │ │ └── Data │ │ │ ├── FoldableTests.hs │ │ │ ├── FunctorTests.hs │ │ │ ├── ListTests.hs │ │ │ └── TraversableTests.hs │ ├── SymPrim │ │ ├── AlgRealTests.hs │ │ ├── BVTests.hs │ │ ├── FPTests.hs │ │ ├── GeneralFunTests.hs │ │ ├── Prim │ │ │ ├── BVTests.hs │ │ │ ├── BitsTests.hs │ │ │ ├── BoolTests.hs │ │ │ ├── ConcurrentTests.hs │ │ │ ├── IntegralTests.hs │ │ │ ├── ModelTests.hs │ │ │ ├── NumTests.hs │ │ │ ├── SerializationTests.hs │ │ │ └── TabularFunTests.hs │ │ ├── QuantifierTests.hs │ │ ├── SomeBVTests.hs │ │ ├── SymGeneralFunTests.hs │ │ ├── SymPrimConstraintTests.hs │ │ ├── SymPrimTests.hs │ │ └── TabularFunTests.hs │ ├── TestUtil │ │ ├── NoMerge.hs │ │ ├── PrettyPrint.hs │ │ └── SymbolicAssertion.hs │ └── Unified │ │ ├── EvalModeTest.hs │ │ ├── GetDataTest.hs │ │ ├── UnifiedClassesTest.hs │ │ └── UnifiedConstructorTest.hs └── Main.hs └── tutorials ├── 1_symbolic_type.ipynb ├── 2_union.ipynb ├── 3_monad_transformer.ipynb ├── README.md └── _img ├── sudoku.svg └── sudoku_solution.svg /.github/workflows/hlint.yml: -------------------------------------------------------------------------------- 1 | name: HLint 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - main 7 | - 'releases/*' 8 | jobs: 9 | hlint: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v4 13 | - name: 'Set up HLint' 14 | uses: haskell-actions/hlint-setup@v2.4.10 15 | with: 16 | version: 3.8 17 | - name: 'Run HLint' 18 | uses: haskell-actions/hlint-run@v2.4.10 19 | with: 20 | fail-on: warning 21 | -------------------------------------------------------------------------------- /.github/workflows/ormolu.yml: -------------------------------------------------------------------------------- 1 | name: Auto format by ormolu 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - main 7 | - 'releases/*' 8 | jobs: 9 | ormolu: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v4 13 | - uses: haskell-actions/run-ormolu@v16 14 | with: 15 | mode: inplace 16 | version: 0.7.7.0 17 | - name: apply formatting changes 18 | uses: stefanzweifel/git-auto-commit-action@v5 19 | if: ${{ always() }} 20 | with: 21 | commit_message: ":art: automated ormolu commit" 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | .vscode/ 25 | .envrc 26 | .direnv/ 27 | *.o-boot 28 | .ipynb_checkpoints/ 29 | .DS_Store 30 | *.smt2 31 | *.eventlog.html 32 | *.dump-splices 33 | result 34 | .pre-commit-config.yaml 35 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: Redundant bracket} 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2021-2024, Sirui Lu (siruilu@cs.washington.edu) 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: grisette.cabal 2 | allow-newer: base 3 | 4 | package grisette 5 | tests: True 6 | -------------------------------------------------------------------------------- /doctest/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.DocTest (doctest) 4 | 5 | main :: IO () 6 | main = do 7 | doctest 8 | [ "-isrc", 9 | "--fast", 10 | "-XBinaryLiterals", 11 | "-XDataKinds", 12 | "-XDeriveAnyClass", 13 | "-XDeriveGeneric", 14 | "-XDeriveLift", 15 | "-XDerivingStrategies", 16 | "-XDerivingVia", 17 | "-XFlexibleContexts", 18 | "-XFlexibleInstances", 19 | "-XFunctionalDependencies", 20 | "-XLambdaCase", 21 | "-XMonoLocalBinds", 22 | "-XMultiParamTypeClasses", 23 | "-XOverloadedStrings", 24 | "-XScopedTypeVariables", 25 | "-XStandaloneDeriving", 26 | "-XTemplateHaskell", 27 | "-XTypeApplications", 28 | "-XTypeOperators", 29 | "-XUndecidableInstances", 30 | "-Wno-unrecognised-warning-flags", 31 | "-Wno-x-partial", 32 | "-Wno-deriving-defaults", 33 | "src" 34 | ] 35 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Examples for Grisette 2 | 3 | Some examples for Grisette. 4 | -------------------------------------------------------------------------------- /examples/grisette-examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: grisette-examples 8 | version: 0.12.0.0 9 | synopsis: Examples for Grisette 10 | description: More examples are available in the 11 | [tutorials](https://github.com/lsrcz/grisette/tree/main/tutorials) of 12 | Grisette. 13 | category: Formal Methods, Theorem Provers, Symbolic Computation, SMT 14 | homepage: https://github.com/lsrcz/grisette#readme 15 | bug-reports: https://github.com/lsrcz/grisette/issues 16 | author: Sirui Lu, Rastislav Bodík 17 | maintainer: Sirui Lu (siruilu@cs.washington.edu) 18 | copyright: 2021-2024 Sirui Lu 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/lsrcz/grisette 26 | 27 | executable basic 28 | main-is: Main.hs 29 | other-modules: 30 | Paths_grisette_examples 31 | hs-source-dirs: 32 | basic 33 | build-depends: 34 | base >=4.14 && <5 35 | , grisette ==0.12.* 36 | default-language: Haskell2010 37 | -------------------------------------------------------------------------------- /examples/package.yaml: -------------------------------------------------------------------------------- 1 | name: grisette-examples 2 | version: 0.12.0.0 3 | synopsis: Examples for Grisette 4 | description: | 5 | More examples are available in the 6 | [tutorials](https://github.com/lsrcz/grisette/tree/main/tutorials) of 7 | Grisette. 8 | category: Formal Methods, Theorem Provers, Symbolic Computation, SMT 9 | author: "Sirui Lu, Rastislav Bodík" 10 | maintainer: Sirui Lu (siruilu@cs.washington.edu) 11 | github: lsrcz/grisette 12 | copyright: "2021-2024 Sirui Lu" 13 | extra-source-files: 14 | - README.md 15 | dependencies: 16 | - base >= 4.14 && < 5 17 | - grisette >= 0.12 && < 0.13 18 | executables: 19 | basic: 20 | source-dirs: basic 21 | main: Main.hs 22 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Symbolic evaluation as a library"; 3 | inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; 4 | inputs.flake-utils.url = "github:numtide/flake-utils"; 5 | inputs.grisette-nix-build-env.url = "github:lsrcz/grisette-nix-build-env/main"; 6 | 7 | outputs = 8 | { 9 | self, 10 | nixpkgs, 11 | flake-utils, 12 | grisette-nix-build-env, 13 | }: 14 | flake-utils.lib.eachDefaultSystem ( 15 | system: 16 | grisette-nix-build-env.lib.${system}.output { 17 | inherit nixpkgs system; 18 | srcRoot = ./.; 19 | extraHaskellPackages = 20 | pkgs: ghcVersion: hfinal: helpers: setCIOptions: with helpers; { 21 | grisette = setCIOptions { 22 | extraTestToolDepends = byGhcVersion { 23 | "8107" = [ pkgs.z3 ]; 24 | "902" = [ pkgs.z3 ]; 25 | default = [ 26 | pkgs.z3 27 | pkgs.bitwuzla 28 | ]; 29 | }; 30 | package = hfinal.callCabal2nix "grisette" ./. { }; 31 | mixDirs = [ 32 | "" 33 | "spec/spec-tmp" 34 | "doctest/doctest-tmp" 35 | ]; 36 | }; 37 | 38 | }; 39 | devShellExtraBuildInputs = 40 | pkgs: 41 | { 42 | bitwuzla ? false, 43 | isDevelopmentEnvironment ? false, 44 | ... 45 | }: 46 | [ 47 | pkgs.boolector 48 | pkgs.cvc5 49 | ] 50 | ++ (if bitwuzla then [ pkgs.bitwuzla ] else [ ]) 51 | ++ ( 52 | if isDevelopmentEnvironment then 53 | [ 54 | (pkgs.ihaskell.override { 55 | ghcWithPackages = pkgs.haskellPackages.ghcWithPackages; 56 | }) 57 | ] 58 | else 59 | [ ] 60 | ); 61 | treefmtExcludes = [ 62 | "tutorials/*.ipynb" 63 | "tutorials/*.svg" 64 | ".gdbinit" 65 | ]; 66 | pname = "grisette"; 67 | extraOutputs = pkgs: haskellPackages: devShellWithVersion: { 68 | devShells = { 69 | "9101" = devShellWithVersion { 70 | ghcVersion = "9101"; 71 | config = { 72 | isDevelopmentEnvironment = true; 73 | bitwuzla = true; 74 | }; 75 | }; 76 | default = devShellWithVersion { 77 | ghcVersion = "9101"; 78 | config = { 79 | isDevelopmentEnvironment = true; 80 | bitwuzla = true; 81 | }; 82 | }; 83 | "9121" = devShellWithVersion { 84 | ghcVersion = "9121"; 85 | config = { 86 | isDevelopmentEnvironment = false; 87 | bitwuzla = true; 88 | }; 89 | }; 90 | }; 91 | }; 92 | } 93 | ); 94 | } 95 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "./src" 4 | component: "grisette:lib" 5 | - path: "./doctest" 6 | component: "grisette:test:doctest" 7 | - path: "./test" 8 | component: "grisette:test:spec" 9 | - path: "examples/basic/Main.hs" 10 | component: "grisette-examples:exe:basic" 11 | - path: "examples/basic/Paths_grisette_examples.hs" 12 | component: "grisette-examples:exe:basic" 13 | - path: "examples/exception/Main.hs" 14 | component: "grisette-examples:exe:exception" 15 | - path: "examples/exception/Paths_grisette_examples.hs" 16 | component: "grisette-examples:exe:exception" 17 | -------------------------------------------------------------------------------- /src/Grisette.hs: -------------------------------------------------------------------------------- 1 | -- Disable this warning because we are re-exporting things. 2 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 3 | 4 | -- | 5 | -- Module : Grisette 6 | -- Copyright : (c) Sirui Lu 2021-2024 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette 13 | ( -- | Grisette is a tool for performing symbolic evaluation on programs. With 14 | -- Grisette, you can construct your own symbolic DSL and obtain the symbolic 15 | -- evaluator for it without manually implementing the symbolic evaluation 16 | -- algorithms. A brief introduction to symbolic evaluation is available in 17 | -- the "Grisette.Core" module. 18 | -- 19 | -- This module exports most of the Grisette APIs. Additional lifted library 20 | -- constructs are in the submodules of @Grisette.Lib@, which are not 21 | -- exported here and should be imported explicitly. For example, to use 22 | -- the lifted "Data.List" functions, you should import 23 | -- "Grisette.Lib.Data.List" explicitly. 24 | -- 25 | -- Grisette also provides an experimental API for unifying symbolic and 26 | -- concrete code to avoid code duplication. This API is exported in the 27 | -- "Grisette.Unified" module. The module should be imported qualified, as 28 | -- it intentionally uses the same names as the "Grisette" module. 29 | -- 30 | -- The following shows a typical import list: 31 | -- 32 | -- > import Grisette 33 | -- > import Grisette.Lib.Data.List 34 | -- > import qualified Grisette.Unified as U 35 | -- > import qualified Grisette.Unified.Lib.Data.List as U 36 | -- 37 | -- Other highly experimental APIs are exported in "Grisette.Experimental" 38 | -- and its submodules. These APIs are not stable, may be buggy and poorly 39 | -- maintained, and do not follow the PVP rules. 40 | 41 | -- * Core modules 42 | 43 | -- | This module exports the core operations for manipulating symbolic 44 | -- values. 45 | module Grisette.Core, 46 | 47 | -- * Symbolic primitives 48 | 49 | -- | This module provides primitive types for symbolic evaluation. 50 | module Grisette.SymPrim, 51 | 52 | -- * Solver backend 53 | 54 | -- | This module provides the configuration of the solver backends. 55 | module Grisette.Backend, 56 | 57 | -- * Core libraries 58 | 59 | -- | This module exports the core lifted library constructs. 60 | module Grisette.Lib.Base, 61 | 62 | -- * Utils 63 | 64 | -- | This module exports utility functions for working with size-tagged 65 | -- types. 66 | module Grisette.Utils, 67 | 68 | -- * Template Haskell 69 | 70 | -- | This module provides template haskell procedures that help with type 71 | -- class derivation and constructing some smart constructors. 72 | module Grisette.TH, 73 | ) 74 | where 75 | 76 | import Grisette.Backend 77 | import Grisette.Core 78 | import Grisette.Lib.Base 79 | import Grisette.SymPrim 80 | import Grisette.TH 81 | import Grisette.Utils 82 | -------------------------------------------------------------------------------- /src/Grisette/Backend.hs: -------------------------------------------------------------------------------- 1 | -- Disable this warning because we are re-exporting things. 2 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 3 | 4 | -- | 5 | -- Module : Grisette.Backend 6 | -- Copyright : (c) Sirui Lu 2021-2023 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Backend 13 | ( -- * SMT backend configuration 14 | GrisetteSMTConfig (..), 15 | boolector, 16 | bitwuzla, 17 | cvc4, 18 | cvc5, 19 | yices, 20 | dReal, 21 | z3, 22 | mathSAT, 23 | abc, 24 | 25 | -- * Changing the extra configurations 26 | ExtraConfig (..), 27 | withTimeout, 28 | clearTimeout, 29 | 30 | -- * SBV backend solver configuration 31 | SBV.SMTConfig (..), 32 | SBV.Logic (..), 33 | SBVC.SMTOption (..), 34 | SBV.Timing (..), 35 | SBV.SMTSolver (..), 36 | ) 37 | where 38 | 39 | import qualified Data.SBV as SBV 40 | import qualified Data.SBV.Control as SBVC 41 | import Grisette.Internal.Backend.Solving 42 | ( ExtraConfig (..), 43 | GrisetteSMTConfig (..), 44 | abc, 45 | bitwuzla, 46 | boolector, 47 | clearTimeout, 48 | cvc4, 49 | cvc5, 50 | dReal, 51 | mathSAT, 52 | withTimeout, 53 | yices, 54 | z3, 55 | ) 56 | -------------------------------------------------------------------------------- /src/Grisette/Experimental.hs: -------------------------------------------------------------------------------- 1 | -- Disable this warning because we are re-exporting things. 2 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 3 | 4 | -- | 5 | -- Module : Grisette.Experimental 6 | -- Copyright : (c) Sirui Lu 2024 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Experimental 13 | ( -- * Experimental features 14 | 15 | -- | The experimental features are likely to be changed in the future, 16 | -- and they do not comply with the semantics versioning policy. 17 | -- 18 | -- Use the APIs with caution. 19 | 20 | -- ** Symbolic Generation with Errors Class 21 | GenSymConstrained (..), 22 | GenSymSimpleConstrained (..), 23 | genSymConstrained, 24 | genSymSimpleConstrained, 25 | derivedSimpleFreshConstrainedNoSpec, 26 | derivedSimpleFreshConstrainedSameShape, 27 | derivedFreshConstrainedNoSpec, 28 | 29 | -- ** Some common GenSymConstrained specifications 30 | SymOrdUpperBound (..), 31 | SymOrdLowerBound (..), 32 | SymOrdBound (..), 33 | ) 34 | where 35 | 36 | import Grisette.Experimental.GenSymConstrained 37 | ( GenSymConstrained (..), 38 | GenSymSimpleConstrained (..), 39 | SymOrdBound (..), 40 | SymOrdLowerBound (..), 41 | SymOrdUpperBound (..), 42 | derivedFreshConstrainedNoSpec, 43 | derivedSimpleFreshConstrainedNoSpec, 44 | derivedSimpleFreshConstrainedSameShape, 45 | genSymConstrained, 46 | genSymSimpleConstrained, 47 | ) 48 | -------------------------------------------------------------------------------- /src/Grisette/Experimental/Qualified/ParallelUnionDo.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Qualified.ParallelUnionDo 3 | -- Copyright : (c) Sirui Lu 2023 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Experimental.Qualified.ParallelUnionDo ((>>=), (>>)) where 10 | 11 | import Control.Parallel.Strategies (NFData) 12 | import Grisette.Experimental.MonadParallelUnion 13 | ( MonadParallelUnion (parBindUnion), 14 | ) 15 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 16 | import Prelude (const, ($)) 17 | 18 | -- | Parallel '(>>=)' operation. 19 | (>>=) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> (a -> m b) -> m b 20 | (>>=) = parBindUnion 21 | 22 | -- | Parallel '(>>)' operation. 23 | (>>) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> m b -> m b 24 | (>>) a b = parBindUnion a $ const b 25 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Control/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE Trustworthy #-} 8 | 9 | -- | 10 | -- Module : Grisette.Internal.Core.Control.Exception 11 | -- Copyright : (c) Sirui Lu 2021-2023 12 | -- License : BSD-3-Clause (see the LICENSE file) 13 | -- 14 | -- Maintainer : siruilu@cs.washington.edu 15 | -- Stability : Experimental 16 | -- Portability : GHC only 17 | module Grisette.Internal.Core.Control.Exception 18 | ( -- * Predefined exceptions 19 | AssertionError (..), 20 | VerificationConditions (..), 21 | ) 22 | where 23 | 24 | import Control.DeepSeq (NFData) 25 | import GHC.Generics (Generic) 26 | 27 | -- $setup 28 | -- >>> import Grisette.Core 29 | -- >>> import Grisette.Lib.Base 30 | -- >>> import Grisette.SymPrim 31 | -- >>> import Control.Monad.Trans.Except 32 | 33 | -- | Assertion error. 34 | data AssertionError = AssertionError 35 | deriving (Show, Eq, Ord, Generic, NFData) 36 | 37 | -- | Verification conditions. 38 | -- A crashed program path can terminate with either assertion violation errors or assumption violation errors. 39 | data VerificationConditions 40 | = AssertionViolation 41 | | AssumptionViolation 42 | deriving (Show, Eq, Ord, Generic, NFData) 43 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Control/Monad/Class/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | -- | 9 | -- Module : Grisette.Internal.Core.Control.Monad.Class.Union 10 | -- Copyright : (c) Sirui Lu 2021-2024 11 | -- License : BSD-3-Clause (see the LICENSE file) 12 | -- 13 | -- Maintainer : siruilu@cs.washington.edu 14 | -- Stability : Experimental 15 | -- Portability : GHC only 16 | module Grisette.Internal.Core.Control.Monad.Class.Union 17 | ( -- * MonadUnion 18 | MonadUnion, 19 | ) 20 | where 21 | 22 | import Grisette.Internal.Core.Data.Class.SimpleMergeable (SymBranching) 23 | 24 | -- $setup 25 | -- >>> import Grisette.Core 26 | -- >>> import Grisette.SymPrim 27 | 28 | -- | Class for monads that support union-like operations and 29 | -- 'Grisette.Core.Data.Class.Mergeable' knowledge propagation. 30 | type MonadUnion u = (SymBranching u, Monad u) 31 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Control/Monad/Union.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Control.Monad.Union 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Control.Monad.Union 12 | ( -- * Union and helpers 13 | Union (..), 14 | UnionKey, 15 | unionUnaryOp, 16 | unionBinOp, 17 | isMerged, 18 | unionSize, 19 | ) 20 | where 21 | 22 | import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union 23 | import Grisette.Internal.Internal.Impl.Core.Control.Monad.Union 24 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/EvalSym.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.EvalSym 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.EvalSym 12 | ( -- * Evaluating symbolic values with model 13 | EvalSym (..), 14 | evalSymToCon, 15 | EvalSym1 (..), 16 | evalSym1, 17 | evalSymToCon1, 18 | EvalSym2 (..), 19 | evalSym2, 20 | evalSymToCon2, 21 | 22 | -- * Generic 'EvalSym' 23 | EvalSymArgs (..), 24 | GEvalSym (..), 25 | genericEvalSym, 26 | genericLiftEvalSym, 27 | ) 28 | where 29 | 30 | import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym 31 | import Grisette.Internal.Internal.Impl.Core.Data.Class.EvalSym () 32 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/ExtractSym.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.ExtractSym 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.ExtractSym 12 | ( -- * Extracting symbolic constant set from a value 13 | ExtractSym (..), 14 | ExtractSym1 (..), 15 | extractSymMaybe1, 16 | extractSym1, 17 | ExtractSym2 (..), 18 | extractSymMaybe2, 19 | extractSym2, 20 | 21 | -- * Generic 'ExtractSym' 22 | ExtractSymArgs (..), 23 | GExtractSym (..), 24 | genericExtractSymMaybe, 25 | genericLiftExtractSymMaybe, 26 | ) 27 | where 28 | 29 | import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym 30 | import Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym () 31 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/Function.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | -- | 7 | -- Module : Grisette.Internal.Core.Data.Class.Function 8 | -- Copyright : (c) Sirui Lu 2021-2023 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Internal.Core.Data.Class.Function 15 | ( -- * Function operations 16 | Function (..), 17 | Apply (..), 18 | ) 19 | where 20 | 21 | -- $setup 22 | -- >>> import Grisette.Core 23 | -- >>> import Grisette.SymPrim 24 | 25 | -- | Abstraction for function-like types. 26 | class Function f arg ret | f -> arg ret where 27 | -- | Function application operator. 28 | -- 29 | -- The operator is not right associated (like `($)`). It is left associated, 30 | -- and you can provide many arguments with this operator once at a time. 31 | -- 32 | -- >>> (+1) # 2 33 | -- 3 34 | -- 35 | -- >>> (+) # 2 # 3 36 | -- 5 37 | (#) :: f -> arg -> ret 38 | 39 | infixl 9 # 40 | 41 | instance Function (a -> b) a b where 42 | f # a = f a 43 | 44 | -- | Applying an uninterpreted function. 45 | -- 46 | -- >>> let f = "f" :: SymInteger =~> SymInteger =~> SymInteger 47 | -- >>> apply f "a" "b" 48 | -- (apply (apply f a) b) 49 | -- 50 | -- Note that for implementation reasons, you can also use `apply` function on 51 | -- a non-function symbolic value. In this case, the function is treated as an 52 | -- `id` function. 53 | class Apply uf where 54 | type FunType uf 55 | apply :: uf -> FunType uf 56 | 57 | instance Apply Integer where 58 | type FunType Integer = Integer 59 | apply = id 60 | 61 | instance Apply Bool where 62 | type FunType Bool = Bool 63 | apply = id 64 | 65 | instance (Apply b) => Apply (a -> b) where 66 | type FunType (a -> b) = a -> FunType b 67 | apply f a = apply (f a) 68 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/Mergeable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.Mergeable 5 | -- Copyright : (c) Sirui Lu 2021-2023 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.Mergeable 12 | ( -- * Merging strategy 13 | MergingStrategy (..), 14 | 15 | -- * Mergeable 16 | Mergeable (..), 17 | Mergeable1 (..), 18 | rootStrategy1, 19 | Mergeable2 (..), 20 | rootStrategy2, 21 | Mergeable3 (..), 22 | rootStrategy3, 23 | 24 | -- * Generic 'Mergeable' 25 | MergeableArgs (..), 26 | GMergeable (..), 27 | genericRootStrategy, 28 | genericLiftRootStrategy, 29 | 30 | -- * Combinators for manually building merging strategies 31 | wrapStrategy, 32 | product2Strategy, 33 | DynamicSortedIdx (..), 34 | StrategyList (..), 35 | buildStrategyList, 36 | resolveStrategy, 37 | resolveStrategy', 38 | resolveMergeable1, 39 | ) 40 | where 41 | 42 | import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable 43 | import Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable () 44 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/PPrint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 3 | 4 | -- | 5 | -- Module : Grisette.Internal.Core.Data.Class.PPrint 6 | -- Copyright : (c) Sirui Lu 2021-2024 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Internal.Core.Data.Class.PPrint 13 | ( -- * Pretty printing 14 | PPrint (..), 15 | docToTextWith, 16 | docToTextWithWidth, 17 | docToText, 18 | pformatTextWith, 19 | pformatTextWithWidth, 20 | pformatText, 21 | pprint, 22 | PPrint1 (..), 23 | pformatPrec1, 24 | pformatList1, 25 | PPrint2 (..), 26 | pformatPrec2, 27 | pformatList2, 28 | 29 | -- * Generic 'PPrint' 30 | genericPFormatPrec, 31 | genericLiftPFormatPrec, 32 | genericPFormatList, 33 | genericLiftPFormatList, 34 | PPrintArgs (..), 35 | GPPrint (..), 36 | PPrintType (..), 37 | 38 | -- * Helpers 39 | groupedEnclose, 40 | condEnclose, 41 | pformatWithConstructor, 42 | pformatWithConstructorNoAlign, 43 | viaShowsPrec, 44 | 45 | -- * Re-exports 46 | module Prettyprinter, 47 | ) 48 | where 49 | 50 | #if MIN_VERSION_prettyprinter(1,7,0) 51 | import Prettyprinter 52 | #else 53 | import Data.Text.Prettyprint.Doc as Prettyprinter 54 | #endif 55 | 56 | import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint 57 | import Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint () 58 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/SafeDiv.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.SafeDiv 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.SafeDiv 12 | ( ArithException (..), 13 | SafeDiv (..), 14 | DivOr (..), 15 | divOrZero, 16 | modOrDividend, 17 | quotOrZero, 18 | remOrDividend, 19 | divModOrZeroDividend, 20 | quotRemOrZeroDividend, 21 | ) 22 | where 23 | 24 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv 25 | import Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv () 26 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/SignConversion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.SignConversion 5 | -- Copyright : (c) Sirui Lu 2023-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.SignConversion 12 | ( SignConversion (..), 13 | ) 14 | where 15 | 16 | import Data.Int (Int16, Int32, Int64, Int8) 17 | import Data.Word (Word16, Word32, Word64, Word8) 18 | 19 | -- | Convert values between signed and unsigned. 20 | class SignConversion ubv sbv | ubv -> sbv, sbv -> ubv where 21 | -- | Convert unsigned value to the corresponding signed value. 22 | toSigned :: ubv -> sbv 23 | 24 | -- | Convert signed value to the corresponding unsigned value. 25 | toUnsigned :: sbv -> ubv 26 | 27 | instance SignConversion Word8 Int8 where 28 | toSigned = fromIntegral 29 | toUnsigned = fromIntegral 30 | 31 | instance SignConversion Word16 Int16 where 32 | toSigned = fromIntegral 33 | toUnsigned = fromIntegral 34 | 35 | instance SignConversion Word32 Int32 where 36 | toSigned = fromIntegral 37 | toUnsigned = fromIntegral 38 | 39 | instance SignConversion Word64 Int64 where 40 | toSigned = fromIntegral 41 | toUnsigned = fromIntegral 42 | 43 | instance SignConversion Word Int where 44 | toSigned = fromIntegral 45 | toUnsigned = fromIntegral 46 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.SimpleMergeable 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.SimpleMergeable 12 | ( -- * Simple mergeable types 13 | SimpleMergeable (..), 14 | SimpleMergeable1 (..), 15 | mrgIte1, 16 | SimpleMergeable2 (..), 17 | mrgIte2, 18 | 19 | -- * Generic 'SimpleMergeable' 20 | SimpleMergeableArgs (..), 21 | GSimpleMergeable (..), 22 | genericMrgIte, 23 | genericLiftMrgIte, 24 | 25 | -- * Symbolic branching 26 | SymBranching (..), 27 | mrgIf, 28 | mergeWithStrategy, 29 | merge, 30 | ) 31 | where 32 | 33 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable 34 | import Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable () 35 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.Solver 5 | -- Copyright : (c) Sirui Lu 2021-2023 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.Solver 12 | ( -- * Note for the examples 13 | 14 | -- 15 | 16 | -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3) 17 | -- solver is available in @PATH@. 18 | 19 | -- * Solver interfaces 20 | SolvingFailure (..), 21 | MonadicSolver (..), 22 | monadicSolverSolve, 23 | SolverCommand (..), 24 | ConfigurableSolver (..), 25 | Solver (..), 26 | solverSolve, 27 | withSolver, 28 | solve, 29 | solverSolveMulti, 30 | solveMulti, 31 | 32 | -- * Union with exceptions 33 | UnionWithExcept (..), 34 | solverSolveExcept, 35 | solveExcept, 36 | solverSolveMultiExcept, 37 | solveMultiExcept, 38 | ) 39 | where 40 | 41 | import Grisette.Internal.Internal.Decl.Core.Data.Class.Solver 42 | import Grisette.Internal.Internal.Impl.Core.Data.Class.Solver () 43 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/SubstSym.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.SubstSym 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.SubstSym 12 | ( -- * Substituting symbolic constants 13 | SubstSym (..), 14 | SubstSym1 (..), 15 | substSym1, 16 | SubstSym2 (..), 17 | substSym2, 18 | 19 | -- * Generic 'SubstSym' 20 | SubstSymArgs (..), 21 | GSubstSym (..), 22 | genericSubstSym, 23 | genericLiftSubstSym, 24 | ) 25 | where 26 | 27 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym 28 | import Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym () 29 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/SymEq.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.SymEq 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.SymEq 12 | ( -- * Symbolic equality 13 | SymEq (..), 14 | SymEq1 (..), 15 | symEq1, 16 | SymEq2 (..), 17 | symEq2, 18 | pairwiseSymDistinct, 19 | 20 | -- * More 'Eq' helper 21 | distinct, 22 | 23 | -- * Generic 'SymEq' 24 | SymEqArgs (..), 25 | GSymEq (..), 26 | genericSymEq, 27 | genericLiftSymEq, 28 | ) 29 | where 30 | 31 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq 32 | import Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq () 33 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/SymOrd.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.SymOrd 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.SymOrd 12 | ( -- * Symbolic total order relation 13 | SymOrd (..), 14 | SymOrd1 (..), 15 | symCompare1, 16 | SymOrd2 (..), 17 | symCompare2, 18 | 19 | -- * Min and max 20 | symMax, 21 | symMin, 22 | mrgMax, 23 | mrgMin, 24 | 25 | -- * Generic 'SymOrd' 26 | SymOrdArgs (..), 27 | GSymOrd (..), 28 | genericSymCompare, 29 | genericLiftSymCompare, 30 | ) 31 | where 32 | 33 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd 34 | import Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd () 35 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/ToCon.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.ToCon 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.ToCon 12 | ( -- * Converting to concrete values 13 | ToCon (..), 14 | ToCon1 (..), 15 | toCon1, 16 | ToCon2 (..), 17 | toCon2, 18 | 19 | -- * Generic 'ToCon' 20 | ToConArgs (..), 21 | GToCon (..), 22 | genericToCon, 23 | genericLiftToCon, 24 | ) 25 | where 26 | 27 | import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon 28 | import Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon () 29 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/ToSym.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.ToSym 5 | -- Copyright : (c) Sirui Lu 2021-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.ToSym 12 | ( -- * Converting to symbolic values 13 | ToSym (..), 14 | ToSym1 (..), 15 | toSym1, 16 | ToSym2 (..), 17 | toSym2, 18 | 19 | -- * Generic 'ToSym' 20 | ToSymArgs (..), 21 | GToSym (..), 22 | genericToSym, 23 | genericLiftToSym, 24 | ) 25 | where 26 | 27 | import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym 28 | import Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym () 29 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/Class/TryMerge.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Core.Data.Class.TryMerge 5 | -- Copyright : (c) Sirui Lu 2023-2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Core.Data.Class.TryMerge 12 | ( TryMerge (..), 13 | tryMerge, 14 | MonadTryMerge, 15 | mrgSingle, 16 | mrgSingleWithStrategy, 17 | mrgToSym, 18 | toUnionSym, 19 | ) 20 | where 21 | 22 | import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge 23 | import Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge () 24 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/SExpr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveLift #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 8 | 9 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 10 | 11 | -- | 12 | -- Module : Grisette.Internal.Core.Data.SExpr 13 | -- Copyright : (c) Sirui Lu 2024 14 | -- License : BSD-3-Clause (see the LICENSE file) 15 | -- 16 | -- Maintainer : siruilu@cs.washington.edu 17 | -- Stability : Experimental 18 | -- Portability : GHC only 19 | module Grisette.Internal.Core.Data.SExpr 20 | ( SExpr (..), 21 | showsSExprWithParens, 22 | parseFileLocation, 23 | fileLocation, 24 | ) 25 | where 26 | 27 | import Control.DeepSeq (NFData) 28 | import qualified Data.Binary as Binary 29 | import Data.Bytes.Serial (Serial (deserialize, serialize)) 30 | import Data.Hashable (Hashable) 31 | import qualified Data.Serialize as Cereal 32 | import Data.Serialize.Text () 33 | import qualified Data.Text as T 34 | import Debug.Trace.LocationTH (__LOCATION__) 35 | import GHC.Generics (Generic) 36 | import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce) 37 | import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice) 38 | 39 | -- | S-expression data type. Used for symbol metadata. 40 | data SExpr = Atom T.Text | List [SExpr] | NumberAtom Integer | BoolAtom Bool 41 | deriving stock (Eq, Ord, Generic, Lift) 42 | deriving anyclass (Hashable, NFData, Serial) 43 | 44 | instance Cereal.Serialize SExpr where 45 | put = serialize 46 | get = deserialize 47 | 48 | instance Binary.Binary SExpr where 49 | put = serialize 50 | get = deserialize 51 | 52 | instance Show SExpr where 53 | showsPrec _ = showsSExprWithParens '(' ')' 54 | 55 | unwordsS :: [ShowS] -> ShowS 56 | unwordsS [] = id 57 | unwordsS [x] = x 58 | unwordsS (x : xs) = x . showString " " . unwordsS xs 59 | 60 | -- | Show an S-expression with specific parentheses. 61 | showsSExprWithParens :: Char -> Char -> SExpr -> ShowS 62 | showsSExprWithParens _ _ (Atom s) = showString $ T.unpack s 63 | showsSExprWithParens lp rp (List l) = 64 | showString [lp] . unwordsS (map shows l) . (showString [rp]) 65 | showsSExprWithParens _ _ (NumberAtom n) = shows n 66 | showsSExprWithParens _ _ (BoolAtom b) = showString $ if b then "#t" else "#f" 67 | 68 | -- | Parse a file location string into an S-expression. 69 | parseFileLocation :: String -> SExpr 70 | parseFileLocation str = 71 | let r = reverse str 72 | (s2, r1) = break (== '-') r 73 | (s1, r2) = break (== ':') $ tail r1 74 | (l, p) = break (== ':') $ tail r2 75 | in List 76 | [ Atom "grisette-file-location", 77 | Atom $ T.pack $ reverse $ tail p, 78 | NumberAtom $ read $ reverse l, 79 | List 80 | [ NumberAtom $ read $ reverse s1, 81 | NumberAtom $ read $ reverse s2 82 | ] 83 | ] 84 | 85 | -- | Get the file location of the splice. 86 | fileLocation :: SpliceQ SExpr 87 | fileLocation = 88 | [||parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)||] 89 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Core/Data/UnionBase.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Internal.Core.Data.UnionBase 3 | -- Copyright : (c) Sirui Lu 2021-2024 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Internal.Core.Data.UnionBase 10 | ( -- * The union data structure. 11 | 12 | -- | Please consider using 'Grisette.Core.Union' instead. 13 | UnionBase (..), 14 | ifWithLeftMost, 15 | ifWithStrategy, 16 | fullReconstruct, 17 | ) 18 | where 19 | 20 | import Grisette.Internal.Internal.Decl.Core.Data.UnionBase 21 | ( UnionBase (UnionIf, UnionSingle), 22 | fullReconstruct, 23 | ifWithLeftMost, 24 | ifWithStrategy, 25 | ) 26 | import Grisette.Internal.Internal.Impl.Core.Data.UnionBase () 27 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedITEOp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | -- | 13 | -- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp 14 | -- Copyright : (c) Sirui Lu 2021-2024 15 | -- License : BSD-3-Clause (see the LICENSE file) 16 | -- 17 | -- Maintainer : siruilu@cs.washington.edu 18 | -- Stability : Experimental 19 | -- Portability : GHC only 20 | module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp 21 | ( UnifiedITEOp (..), 22 | ) 23 | where 24 | 25 | import Data.Kind (Constraint) 26 | import Data.Type.Bool (If) 27 | import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) 28 | import Grisette.Internal.Unified.EvalModeTag (IsConMode) 29 | 30 | -- | A class that provides unified equality comparison. 31 | -- 32 | -- We use this type class to help resolve the constraints for `ITEOp`. 33 | class UnifiedITEOp mode v where 34 | withBaseITEOp :: 35 | ((If (IsConMode mode) (() :: Constraint) (ITEOp v)) => r) -> r 36 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSimpleMergeable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE QuantifiedConstraints #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | -- | 14 | -- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable 15 | -- Copyright : (c) Sirui Lu 2024 16 | -- License : BSD-3-Clause (see the LICENSE file) 17 | -- 18 | -- Maintainer : siruilu@cs.washington.edu 19 | -- Stability : Experimental 20 | -- Portability : GHC only 21 | module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable 22 | ( UnifiedBranching (..), 23 | UnifiedSimpleMergeable (..), 24 | UnifiedSimpleMergeable1 (..), 25 | UnifiedSimpleMergeable2 (..), 26 | ) 27 | where 28 | 29 | import Data.Kind (Constraint) 30 | import Data.Type.Bool (If) 31 | import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable 32 | ( Mergeable, 33 | ) 34 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable 35 | ( SimpleMergeable, 36 | SimpleMergeable1, 37 | SimpleMergeable2, 38 | SymBranching, 39 | ) 40 | import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge 41 | ( TryMerge, 42 | ) 43 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag, IsConMode) 44 | import Grisette.Internal.Unified.Util (DecideEvalMode) 45 | 46 | -- | A class that provides a unified simple merging. 47 | -- 48 | -- We use this type class to help resolve the constraints for `SimpleMergeable`. 49 | class (DecideEvalMode mode, Mergeable a) => UnifiedSimpleMergeable mode a where 50 | withBaseSimpleMergeable :: 51 | ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable a)) => r) -> r 52 | 53 | -- | A class that provides lifting of unified simple merging. 54 | -- 55 | -- We use this type class to help resolve the constraints for 56 | -- `SimpleMergeable1`. 57 | class (DecideEvalMode mode) => UnifiedSimpleMergeable1 mode f where 58 | withBaseSimpleMergeable1 :: 59 | ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 f)) => r) -> r 60 | 61 | -- | A class that provides lifting of unified simple merging. 62 | -- 63 | -- We use this type class to help resolve the constraints for 64 | -- `SimpleMergeable2`. 65 | class (DecideEvalMode mode) => UnifiedSimpleMergeable2 mode f where 66 | withBaseSimpleMergeable2 :: 67 | ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 f)) => r) -> r 68 | 69 | -- | A class that provides a unified branching operation. 70 | -- 71 | -- We use this type class to help resolve the constraints for 72 | -- `SymBranching`. 73 | class 74 | (DecideEvalMode mode, TryMerge m) => 75 | UnifiedBranching (mode :: EvalModeTag) m 76 | where 77 | withBaseBranching :: 78 | ((If (IsConMode mode) (TryMerge m) (SymBranching m)) => r) -> r 79 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE QuantifiedConstraints #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 13 | 14 | {-# HLINT ignore "Eta reduce" #-} 15 | 16 | -- | 17 | -- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq 18 | -- Copyright : (c) Sirui Lu 2024 19 | -- License : BSD-3-Clause (see the LICENSE file) 20 | -- 21 | -- Maintainer : siruilu@cs.washington.edu 22 | -- Stability : Experimental 23 | -- Portability : GHC only 24 | module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq 25 | ( UnifiedSymEq (..), 26 | UnifiedSymEq1 (..), 27 | UnifiedSymEq2 (..), 28 | ) 29 | where 30 | 31 | import Data.Functor.Classes (Eq1, Eq2) 32 | import Data.Type.Bool (If) 33 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq 34 | ( SymEq, 35 | SymEq1, 36 | SymEq2, 37 | ) 38 | import Grisette.Internal.Unified.EvalModeTag (IsConMode) 39 | 40 | -- | A class that provides unified equality comparison. 41 | -- 42 | -- We use this type class to help resolve the constraints for `Eq` and `SymEq`. 43 | class UnifiedSymEq mode a where 44 | withBaseSymEq :: ((If (IsConMode mode) (Eq a) (SymEq a)) => r) -> r 45 | 46 | -- | A class that provides unified lifting of equality comparison. 47 | -- 48 | -- We use this type class to help resolve the constraints for `Eq1` and 49 | -- `SymEq1`. 50 | class 51 | (forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a)) => 52 | UnifiedSymEq1 mode f 53 | where 54 | withBaseSymEq1 :: ((If (IsConMode mode) (Eq1 f) (SymEq1 f)) => r) -> r 55 | 56 | -- | A class that provides unified lifting of equality comparison. 57 | -- 58 | -- We use this type class to help resolve the constraints for `Eq2` and 59 | -- `SymEq2`. 60 | class 61 | (forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a)) => 62 | UnifiedSymEq2 mode f 63 | where 64 | withBaseSymEq2 :: ((If (IsConMode mode) (Eq2 f) (SymEq2 f)) => r) -> r 65 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymOrd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE QuantifiedConstraints #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 13 | 14 | {-# HLINT ignore "Eta reduce" #-} 15 | 16 | -- | 17 | -- Module : Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd 18 | -- Copyright : (c) Sirui Lu 2024 19 | -- License : BSD-3-Clause (see the LICENSE file) 20 | -- 21 | -- Maintainer : siruilu@cs.washington.edu 22 | -- Stability : Experimental 23 | -- Portability : GHC only 24 | module Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd 25 | ( UnifiedSymOrd (..), 26 | UnifiedSymOrd1 (..), 27 | UnifiedSymOrd2 (..), 28 | ) 29 | where 30 | 31 | import Data.Functor.Classes (Ord1, Ord2) 32 | import Data.Type.Bool (If) 33 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd 34 | ( SymOrd, 35 | SymOrd1, 36 | SymOrd2, 37 | ) 38 | import Grisette.Internal.Unified.EvalModeTag (IsConMode) 39 | 40 | -- | A class that provides unified comparison. 41 | -- 42 | -- We use this type class to help resolve the constraints for `Ord` and 43 | -- `SymOrd`. 44 | class UnifiedSymOrd mode a where 45 | withBaseSymOrd :: (((If (IsConMode mode) (Ord a) (SymOrd a)) => r)) -> r 46 | 47 | -- | A class that provides unified lifting of comparison. 48 | -- 49 | -- We use this type class to help resolve the constraints for `Ord1` and 50 | -- `SymOrd1`. 51 | class UnifiedSymOrd1 mode f where 52 | withBaseSymOrd1 :: (((If (IsConMode mode) (Ord1 f) (SymOrd1 f)) => r)) -> r 53 | 54 | -- | A class that provides unified lifting of comparison. 55 | -- 56 | -- We use this type class to help resolve the constraints for `Ord2` and 57 | -- `SymOrd2`. 58 | class UnifiedSymOrd2 mode f where 59 | withBaseSymOrd2 :: (((If (IsConMode mode) (Ord2 f) (SymOrd2 f)) => r)) -> r 60 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Decl/Unified/FPFPConversion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | -- | 12 | -- Module : Grisette.Internal.Internal.Decl.Unified.FPFPConversion 13 | -- Copyright : (c) Sirui Lu 2024 14 | -- License : BSD-3-Clause (see the LICENSE file) 15 | -- 16 | -- Maintainer : siruilu@cs.washington.edu 17 | -- Stability : Experimental 18 | -- Portability : GHC only 19 | module Grisette.Internal.Internal.Decl.Unified.FPFPConversion 20 | ( UnifiedFPFPConversionImpl, 21 | UnifiedFPFPConversion, 22 | AllUnifiedFPFPConversion, 23 | ) 24 | where 25 | 26 | import Grisette.Internal.Core.Data.Class.IEEEFP (IEEEFPConvertible) 27 | import Grisette.Internal.Internal.Decl.Unified.UnifiedFP 28 | ( UnifiedFPImpl (GetFP, GetFPRoundingMode), 29 | ) 30 | import Grisette.Internal.SymPrim.FP (ValidFP) 31 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) 32 | 33 | -- | Implementation for 'UnifiedFPFPConversion'. 34 | class 35 | ( UnifiedFPImpl mode fpn eb0 sb0 fp0 fprd, 36 | UnifiedFPImpl mode fpn eb1 sb1 fp1 fprd, 37 | IEEEFPConvertible fp0 fp1 fprd 38 | ) => 39 | UnifiedFPFPConversionImpl 40 | (mode :: EvalModeTag) 41 | fpn 42 | eb0 43 | sb0 44 | eb1 45 | sb1 46 | fp0 47 | fp1 48 | fprd 49 | 50 | -- | Unified constraints for conversion from floating point numbers to floating 51 | -- point numbers. 52 | class 53 | ( UnifiedFPFPConversionImpl 54 | (mode :: EvalModeTag) 55 | (GetFP mode) 56 | eb0 57 | sb0 58 | eb1 59 | sb1 60 | (GetFP mode eb0 sb0) 61 | (GetFP mode eb1 sb1) 62 | (GetFPRoundingMode mode) 63 | ) => 64 | UnifiedFPFPConversion mode eb0 sb0 eb1 sb1 65 | 66 | -- | Evaluation mode with unified conversion from floating-points to 67 | -- floating-points. 68 | class 69 | ( forall eb0 sb0 eb1 sb1. 70 | (ValidFP eb0 sb0, ValidFP eb1 sb1) => 71 | UnifiedFPFPConversion 72 | mode 73 | eb0 74 | sb0 75 | eb1 76 | sb1 77 | ) => 78 | AllUnifiedFPFPConversion mode 79 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Decl/Unified/UnifiedBool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilyDependencies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | -- | 7 | -- Module : Grisette.Internal.Internal.Decl.Unified.UnifiedBool 8 | -- Copyright : (c) Sirui Lu 2024 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Internal.Internal.Decl.Unified.UnifiedBool 15 | ( UnifiedBool (..), 16 | ) 17 | where 18 | 19 | import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) 20 | import Grisette.Internal.SymPrim.SymBool (SymBool) 21 | import Grisette.Internal.SymPrim.SymPrim (Prim) 22 | import Grisette.Internal.Unified.BaseConstraint 23 | ( ConSymConversion, 24 | ) 25 | import Grisette.Internal.Unified.Class.UnifiedRep 26 | ( UnifiedConRep (ConType), 27 | UnifiedSymRep (SymType), 28 | ) 29 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag) 30 | 31 | -- | Evaluation mode with unified 'Bool' type. 32 | class 33 | ( Prim (GetBool mode), 34 | UnifiedConRep (GetBool mode), 35 | UnifiedSymRep (GetBool mode), 36 | ConType (GetBool mode) ~ Bool, 37 | SymType (GetBool mode) ~ SymBool, 38 | ConSymConversion Bool SymBool (GetBool mode), 39 | LogicalOp (GetBool mode) 40 | ) => 41 | UnifiedBool (mode :: EvalModeTag) 42 | where 43 | -- | Get a unified Boolean type. Resolves to 'Bool' in 'Grisette.Unified.C' 44 | -- mode, and 'SymBool' in 'Grisette.Unified.S' mode. 45 | type GetBool mode = bool | bool -> mode 46 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Impl/Core/Data/Class/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DeriveLift #-} 7 | {-# LANGUAGE DerivingVia #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE FunctionalDependencies #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE TemplateHaskell #-} 17 | {-# LANGUAGE Trustworthy #-} 18 | {-# LANGUAGE TypeFamilies #-} 19 | {-# LANGUAGE UndecidableInstances #-} 20 | 21 | -- | 22 | -- Module : Grisette.Internal.Internal.Impl.Core.Data.Class.Solver 23 | -- Copyright : (c) Sirui Lu 2021-2023 24 | -- License : BSD-3-Clause (see the LICENSE file) 25 | -- 26 | -- Maintainer : siruilu@cs.washington.edu 27 | -- Stability : Experimental 28 | -- Portability : GHC only 29 | module Grisette.Internal.Internal.Impl.Core.Data.Class.Solver () where 30 | 31 | import Control.DeepSeq (NFData) 32 | import qualified Data.Binary as Binary 33 | import Data.Bytes.Serial (Serial (deserialize, serialize)) 34 | import Data.Hashable (Hashable) 35 | import qualified Data.Serialize as Cereal 36 | import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint (PPrint) 37 | import Grisette.Internal.Internal.Decl.Core.Data.Class.Solver (SolvingFailure) 38 | import Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint () 39 | import Grisette.Internal.TH.Derivation.Derive (derive) 40 | 41 | -- $setup 42 | -- >>> import Grisette 43 | -- >>> import Grisette.Core 44 | -- >>> import Grisette.SymPrim 45 | -- >>> import Grisette.Backend 46 | 47 | derive 48 | [''SolvingFailure] 49 | [ ''Show, 50 | ''Eq, 51 | ''PPrint, 52 | ''NFData, 53 | ''Hashable, 54 | ''Serial 55 | ] 56 | 57 | instance Cereal.Serialize SolvingFailure where 58 | put = serialize 59 | get = deserialize 60 | 61 | instance Binary.Binary SolvingFailure where 62 | put = serialize 63 | get = deserialize 64 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Impl/Unified/EvalMode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Internal.Impl.Unified.EvalMode 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Internal.Impl.Unified.EvalMode () where 12 | 13 | import Grisette.Internal.Internal.Decl.Unified.EvalMode 14 | ( EvalModeAll, 15 | EvalModeBV, 16 | EvalModeBase, 17 | EvalModeFP, 18 | ) 19 | import Grisette.Internal.Internal.Impl.Unified.BVFPConversion () 20 | import Grisette.Internal.Internal.Impl.Unified.FPFPConversion () 21 | import Grisette.Internal.Internal.Impl.Unified.UnifiedBV () 22 | import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () 23 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 24 | 25 | instance EvalModeBase 'C 26 | 27 | instance EvalModeBase 'S 28 | 29 | instance EvalModeAll 'C 30 | 31 | instance EvalModeAll 'S 32 | 33 | instance EvalModeBV 'C 34 | 35 | instance EvalModeBV 'S 36 | 37 | instance EvalModeFP 'C 38 | 39 | instance EvalModeFP 'S 40 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Impl/Unified/FPFPConversion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | -- | 12 | -- Module : Grisette.Internal.Internal.Impl.Unified.FPFPConversion 13 | -- Copyright : (c) Sirui Lu 2024 14 | -- License : BSD-3-Clause (see the LICENSE file) 15 | -- 16 | -- Maintainer : siruilu@cs.washington.edu 17 | -- Stability : Experimental 18 | -- Portability : GHC only 19 | module Grisette.Internal.Internal.Impl.Unified.FPFPConversion () where 20 | 21 | import Grisette.Internal.Internal.Decl.Unified.FPFPConversion 22 | ( AllUnifiedFPFPConversion, 23 | UnifiedFPFPConversion, 24 | UnifiedFPFPConversionImpl, 25 | ) 26 | import Grisette.Internal.Internal.Decl.Unified.UnifiedFP 27 | ( UnifiedFPImpl (GetFP, GetFPRoundingMode), 28 | ) 29 | import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () 30 | import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) 31 | import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) 32 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 33 | 34 | instance 35 | (ValidFP eb0 sb0, ValidFP eb1 sb1) => 36 | UnifiedFPFPConversionImpl 37 | 'C 38 | FP 39 | eb0 40 | sb0 41 | eb1 42 | sb1 43 | (FP eb0 sb0) 44 | (FP eb1 sb1) 45 | FPRoundingMode 46 | 47 | instance 48 | (ValidFP eb0 sb0, ValidFP eb1 sb1) => 49 | UnifiedFPFPConversionImpl 50 | 'S 51 | SymFP 52 | eb0 53 | sb0 54 | eb1 55 | sb1 56 | (SymFP eb0 sb0) 57 | (SymFP eb1 sb1) 58 | SymFPRoundingMode 59 | 60 | instance 61 | ( UnifiedFPFPConversionImpl 62 | (mode :: EvalModeTag) 63 | (GetFP mode) 64 | eb0 65 | sb0 66 | eb1 67 | sb1 68 | (GetFP mode eb0 sb0) 69 | (GetFP mode eb1 sb1) 70 | (GetFPRoundingMode mode) 71 | ) => 72 | UnifiedFPFPConversion mode eb0 sb0 eb1 sb1 73 | 74 | instance 75 | ( forall eb0 sb0 eb1 sb1. 76 | (ValidFP eb0 sb0, ValidFP eb1 sb1) => 77 | UnifiedFPFPConversion 78 | mode 79 | eb0 80 | sb0 81 | eb1 82 | sb1 83 | ) => 84 | AllUnifiedFPFPConversion mode 85 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Impl/Unified/UnifiedBool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | -- | 6 | -- Module : Grisette.Internal.Internal.Impl.Unified.UnifiedBool 7 | -- Copyright : (c) Sirui Lu 2024 8 | -- License : BSD-3-Clause (see the LICENSE file) 9 | -- 10 | -- Maintainer : siruilu@cs.washington.edu 11 | -- Stability : Experimental 12 | -- Portability : GHC only 13 | module Grisette.Internal.Internal.Impl.Unified.UnifiedBool () where 14 | 15 | import Grisette.Internal.Internal.Decl.Unified.UnifiedBool 16 | ( UnifiedBool (GetBool), 17 | ) 18 | import Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd () 19 | import Grisette.Internal.SymPrim.SymBool (SymBool) 20 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 21 | 22 | instance UnifiedBool 'C where 23 | type GetBool 'C = Bool 24 | 25 | instance UnifiedBool 'S where 26 | type GetBool 'S = SymBool 27 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Internal/Impl/Unified/UnifiedFP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeFamilyDependencies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | -- | 11 | -- Module : Grisette.Internal.Internal.Impl.Unified.UnifiedFP 12 | -- Copyright : (c) Sirui Lu 2024 13 | -- License : BSD-3-Clause (see the LICENSE file) 14 | -- 15 | -- Maintainer : siruilu@cs.washington.edu 16 | -- Stability : Experimental 17 | -- Portability : GHC only 18 | module Grisette.Internal.Internal.Impl.Unified.UnifiedFP () where 19 | 20 | import Control.Monad.Error.Class (MonadError) 21 | import Grisette.Internal.Internal.Decl.Unified.UnifiedFP 22 | ( AllUnifiedFP, 23 | GetFP, 24 | GetFPRoundingMode, 25 | SafeUnifiedFP, 26 | SafeUnifiedFPImpl, 27 | UnifiedFP, 28 | UnifiedFPImpl, 29 | ) 30 | import Grisette.Internal.SymPrim.FP 31 | ( FP, 32 | FPRoundingMode, 33 | NotRepresentableFPError, 34 | ValidFP, 35 | ) 36 | import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) 37 | import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP) 38 | import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) 39 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 40 | import Grisette.Internal.Unified.UnifiedInteger (GetInteger) 41 | 42 | instance 43 | (ValidFP eb sb) => 44 | UnifiedFPImpl 'C FP eb sb (FP eb sb) FPRoundingMode 45 | where 46 | type GetFP 'C = FP 47 | type GetFPRoundingMode 'C = FPRoundingMode 48 | 49 | instance 50 | (ValidFP eb sb) => 51 | UnifiedFPImpl 'S SymFP eb sb (SymFP eb sb) SymFPRoundingMode 52 | where 53 | type GetFP 'S = SymFP 54 | type GetFPRoundingMode 'S = SymFPRoundingMode 55 | 56 | instance 57 | ( UnifiedFPImpl 58 | mode 59 | (GetFP mode) 60 | eb 61 | sb 62 | (GetFP mode eb sb) 63 | (GetFPRoundingMode mode) 64 | ) => 65 | UnifiedFP mode eb sb 66 | 67 | instance 68 | (UnifiedFPImpl mode fpn eb sb fp rd) => 69 | SafeUnifiedFPImpl mode fpn eb sb fp rd m 70 | 71 | instance 72 | ( SafeUnifiedFPImpl 73 | mode 74 | (GetFP mode) 75 | eb 76 | sb 77 | (GetFP mode eb sb) 78 | (GetFPRoundingMode mode) 79 | m, 80 | UnifiedSafeFromFP 81 | mode 82 | NotRepresentableFPError 83 | (GetInteger mode) 84 | (GetFP mode eb sb) 85 | (GetFPRoundingMode mode) 86 | m 87 | ) => 88 | SafeUnifiedFP mode eb sb m 89 | 90 | instance 91 | ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb, 92 | forall eb sb m. 93 | ( ValidFP eb sb, 94 | UnifiedBranching mode m, 95 | MonadError NotRepresentableFPError m 96 | ) => 97 | SafeUnifiedFP mode eb sb m 98 | ) => 99 | AllUnifiedFP mode 100 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/AllSyms.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.SymPrim.AllSyms 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.SymPrim.AllSyms 12 | ( -- * Get all symbolic primitive values in a value 13 | SomeSym (..), 14 | AllSyms (..), 15 | AllSyms1 (..), 16 | allSymsS1, 17 | AllSyms2 (..), 18 | allSymsS2, 19 | allSymsSize, 20 | symSize, 21 | symsSize, 22 | 23 | -- * Generic 'AllSyms' 24 | AllSymsArgs (..), 25 | GAllSyms (..), 26 | genericAllSymsS, 27 | genericLiftAllSymsS, 28 | ) 29 | where 30 | 31 | import Grisette.Internal.Internal.Decl.SymPrim.AllSyms 32 | import Grisette.Internal.Internal.Impl.SymPrim.AllSyms () 33 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/IntBitwidth.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Internal.SymPrim.IntBitwidth 3 | -- Copyright : (c) Sirui Lu 2021-2023 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) where 10 | 11 | import Data.Bits (FiniteBits (finiteBitSize)) 12 | import Language.Haskell.TH (TyLit (NumTyLit), Type (LitT), TypeQ) 13 | 14 | -- | Get the bitwidth of 'Int'. 15 | intBitwidthQ :: TypeQ 16 | intBitwidthQ = 17 | return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int)) 18 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/ModelRep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | 5 | -- | 6 | -- Module : Grisette.Internal.SymPrim.ModelRep 7 | -- Copyright : (c) Sirui Lu 2024 8 | -- License : BSD-3-Clause (see the LICENSE file) 9 | -- 10 | -- Maintainer : siruilu@cs.washington.edu 11 | -- Stability : Experimental 12 | -- Portability : GHC only 13 | module Grisette.Internal.SymPrim.ModelRep (ModelSymPair (..)) where 14 | 15 | import Grisette.Internal.Core.Data.Class.ModelOps 16 | ( ModelOps (emptyModel, insertValue), 17 | ModelRep (buildModel), 18 | ) 19 | import Grisette.Internal.SymPrim.Prim.Model (Model) 20 | import Grisette.Internal.SymPrim.Prim.Term 21 | ( LinkedRep (underlyingTerm), 22 | pattern SymTerm, 23 | ) 24 | 25 | -- $setup 26 | -- >>> import Grisette.Core 27 | -- >>> import Grisette.SymPrim 28 | -- >>> import Grisette.Backend 29 | -- >>> import Data.Proxy 30 | 31 | -- ModelRep 32 | 33 | -- | A pair of a symbolic constant and its value. 34 | -- This is used to build a model from a list of symbolic constants and their values. 35 | -- 36 | -- >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model 37 | -- Model {a -> 1 :: Integer, b -> true :: Bool} 38 | data ModelSymPair ct st where 39 | (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st 40 | 41 | instance ModelRep (ModelSymPair ct st) Model where 42 | buildModel (sym := val) = 43 | case underlyingTerm sym of 44 | SymTerm symbol -> insertValue symbol val emptyModel 45 | _ -> error "buildModel: should only use symbolic constants" 46 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFloatingTerm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# HLINT ignore "Eta reduce" #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 6 | 7 | -- | 8 | -- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm 9 | -- Copyright : (c) Sirui Lu 2024 10 | -- License : BSD-3-Clause (see the LICENSE file) 11 | -- 12 | -- Maintainer : siruilu@cs.washington.edu 13 | -- Stability : Experimental 14 | -- Portability : GHC only 15 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm () where 16 | 17 | import Grisette.Internal.SymPrim.AlgReal (AlgReal) 18 | import Grisette.Internal.SymPrim.FP (FP, ValidFP) 19 | import Grisette.Internal.SymPrim.Prim.Internal.Term 20 | ( FloatingUnaryOp (FloatingAcosh, FloatingAsinh, FloatingAtanh, FloatingSqrt), 21 | PEvalFloatingTerm 22 | ( pevalFloatingUnaryTerm, 23 | pevalPowerTerm, 24 | withSbvFloatingTermConstraint 25 | ), 26 | SupportedPrim (withPrim), 27 | floatingUnaryTerm, 28 | powerTerm, 29 | ) 30 | import Grisette.Internal.SymPrim.Prim.Internal.Unfold 31 | ( generalUnaryUnfolded, 32 | ) 33 | 34 | instance (ValidFP eb sb) => PEvalFloatingTerm (FP eb sb) where 35 | pevalFloatingUnaryTerm op = 36 | case op of 37 | FloatingSqrt -> generalUnaryUnfolded sqrt $ floatingUnaryTerm op 38 | _ -> error $ "operation " <> show op <> " not supported for FP" 39 | pevalPowerTerm = error "power operation not supported for FP" 40 | withSbvFloatingTermConstraint r = withPrim @(FP eb sb) r 41 | 42 | instance PEvalFloatingTerm AlgReal where 43 | pevalFloatingUnaryTerm op = 44 | case op of 45 | FloatingAsinh -> 46 | error "operation asinh not supported by sbv for AlgReal" 47 | FloatingAcosh -> 48 | error "operation acosh not supported by sbv for AlgReal" 49 | FloatingAtanh -> 50 | error "operation atanh not supported by sbv for AlgReal" 51 | _ -> floatingUnaryTerm op 52 | pevalPowerTerm = powerTerm 53 | withSbvFloatingTermConstraint r = withPrim @AlgReal r 54 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 6 | 7 | {-# HLINT ignore "Eta reduce" #-} 8 | 9 | -- | 10 | -- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm 11 | -- Copyright : (c) Sirui Lu 2024 12 | -- License : BSD-3-Clause (see the LICENSE file) 13 | -- 14 | -- Maintainer : siruilu@cs.washington.edu 15 | -- Stability : Experimental 16 | -- Portability : GHC only 17 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm () where 18 | 19 | import Grisette.Internal.SymPrim.AlgReal (AlgReal) 20 | import Grisette.Internal.SymPrim.FP (FP, ValidFP) 21 | import Grisette.Internal.SymPrim.Prim.Internal.Term 22 | ( PEvalFractionalTerm 23 | ( pevalFdivTerm, 24 | pevalRecipTerm, 25 | withSbvFractionalTermConstraint 26 | ), 27 | SupportedPrim (withPrim), 28 | Term, 29 | conTerm, 30 | fdivTerm, 31 | recipTerm, 32 | pattern ConTerm, 33 | pattern SupportedTerm, 34 | ) 35 | import Grisette.Internal.SymPrim.Prim.Internal.Unfold 36 | ( binaryUnfoldOnce, 37 | generalBinaryUnfolded, 38 | generalUnaryUnfolded, 39 | unaryUnfoldOnce, 40 | ) 41 | 42 | instance (ValidFP eb sb) => PEvalFractionalTerm (FP eb sb) where 43 | pevalFdivTerm = generalBinaryUnfolded (/) fdivTerm 44 | pevalRecipTerm = generalUnaryUnfolded recip recipTerm 45 | withSbvFractionalTermConstraint r = withPrim @(FP eb sb) r 46 | 47 | pevalDefaultFdivTerm :: 48 | (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Term a 49 | pevalDefaultFdivTerm l@SupportedTerm r = 50 | binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm l r 51 | 52 | doPevalDefaultFdivTerm :: 53 | (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Maybe (Term a) 54 | doPevalDefaultFdivTerm (ConTerm a) (ConTerm b) 55 | | b /= 0 = Just $ conTerm $ a / b 56 | doPevalDefaultFdivTerm a (ConTerm 1) = Just a 57 | doPevalDefaultFdivTerm _ _ = Nothing 58 | 59 | pevalDefaultRecipTerm :: 60 | (PEvalFractionalTerm a, Eq a) => Term a -> Term a 61 | pevalDefaultRecipTerm l@SupportedTerm = 62 | unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm l 63 | 64 | doPevalDefaultRecipTerm :: 65 | (PEvalFractionalTerm a, Eq a) => Term a -> Maybe (Term a) 66 | doPevalDefaultRecipTerm (ConTerm n) | n /= 0 = Just $ conTerm $ recip n 67 | doPevalDefaultRecipTerm _ = Nothing 68 | 69 | instance PEvalFractionalTerm AlgReal where 70 | pevalFdivTerm = pevalDefaultFdivTerm 71 | pevalRecipTerm = pevalDefaultRecipTerm 72 | withSbvFractionalTermConstraint r = withPrim @AlgReal r 73 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# HLINT ignore "Eta reduce" #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 9 | 10 | -- | 11 | -- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm 12 | -- Copyright : (c) Sirui Lu 2024 13 | -- License : BSD-3-Clause (see the LICENSE file) 14 | -- 15 | -- Maintainer : siruilu@cs.washington.edu 16 | -- Stability : Experimental 17 | -- Portability : GHC only 18 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm () where 19 | 20 | import Grisette.Internal.SymPrim.AlgReal (AlgReal) 21 | import Grisette.Internal.SymPrim.FP (FP, ValidFP) 22 | import Grisette.Internal.SymPrim.Prim.Internal.Term 23 | ( PEvalNumTerm 24 | ( pevalAbsNumTerm, 25 | pevalAddNumTerm, 26 | pevalMulNumTerm, 27 | pevalNegNumTerm, 28 | pevalSignumNumTerm, 29 | withSbvNumTermConstraint 30 | ), 31 | SupportedPrim (withPrim), 32 | absNumTerm, 33 | addNumTerm, 34 | doPevalNoOverflowAbsNumTerm, 35 | doPevalNoOverflowSignumNumTerm, 36 | mulNumTerm, 37 | negNumTerm, 38 | pevalDefaultAddNumTerm, 39 | pevalDefaultMulNumTerm, 40 | pevalDefaultNegNumTerm, 41 | signumNumTerm, 42 | ) 43 | import Grisette.Internal.SymPrim.Prim.Internal.Unfold 44 | ( generalBinaryUnfolded, 45 | generalUnaryUnfolded, 46 | unaryUnfoldOnce, 47 | ) 48 | 49 | instance PEvalNumTerm Integer where 50 | pevalAddNumTerm = pevalDefaultAddNumTerm 51 | pevalNegNumTerm = pevalDefaultNegNumTerm 52 | pevalMulNumTerm = pevalDefaultMulNumTerm 53 | pevalAbsNumTerm = unaryUnfoldOnce doPevalNoOverflowAbsNumTerm absNumTerm 54 | pevalSignumNumTerm = 55 | unaryUnfoldOnce doPevalNoOverflowSignumNumTerm signumNumTerm 56 | withSbvNumTermConstraint r = r 57 | 58 | instance (ValidFP eb sb) => PEvalNumTerm (FP eb sb) where 59 | pevalAddNumTerm = generalBinaryUnfolded (+) addNumTerm 60 | pevalNegNumTerm = generalUnaryUnfolded negate negNumTerm 61 | pevalMulNumTerm = generalBinaryUnfolded (*) mulNumTerm 62 | pevalAbsNumTerm = generalUnaryUnfolded abs absNumTerm 63 | pevalSignumNumTerm = generalUnaryUnfolded signum signumNumTerm 64 | withSbvNumTermConstraint r = withPrim @(FP eb sb) r 65 | 66 | instance PEvalNumTerm AlgReal where 67 | pevalAddNumTerm = pevalDefaultAddNumTerm 68 | pevalNegNumTerm = pevalDefaultNegNumTerm 69 | pevalMulNumTerm = pevalDefaultMulNumTerm 70 | pevalAbsNumTerm = unaryUnfoldOnce doPevalNoOverflowAbsNumTerm absNumTerm 71 | pevalSignumNumTerm = 72 | unaryUnfoldOnce doPevalNoOverflowSignumNumTerm signumNumTerm 73 | withSbvNumTermConstraint r = withPrim @AlgReal r 74 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | -- | 9 | -- Module : Grisette.Internal.SymPrim.Prim.SomeTerm 10 | -- Copyright : (c) Sirui Lu 2021-2024 11 | -- License : BSD-3-Clause (see the LICENSE file) 12 | -- 13 | -- Maintainer : siruilu@cs.washington.edu 14 | -- Stability : Experimental 15 | -- Portability : GHC only 16 | module Grisette.Internal.SymPrim.Prim.SomeTerm 17 | ( SomeTerm (..), 18 | someTerm, 19 | someTermId, 20 | ) 21 | where 22 | 23 | import Data.Hashable (Hashable (hashWithSalt)) 24 | import Data.Typeable (eqT, type (:~:) (Refl)) 25 | import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id) 26 | import Grisette.Internal.SymPrim.Prim.Internal.Term 27 | ( SupportedPrim (primTypeRep), 28 | Term, 29 | termId, 30 | pattern SupportedTerm, 31 | ) 32 | 33 | -- | Existential wrapper for symbolic Grisette terms. 34 | data SomeTerm where 35 | SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm 36 | 37 | instance Eq SomeTerm where 38 | (SomeTerm (t1 :: Term a)) == (SomeTerm (t2 :: Term b)) = 39 | case eqT @a @b of 40 | Just Refl -> t1 == t2 41 | Nothing -> False 42 | 43 | instance Hashable SomeTerm where 44 | hashWithSalt s (SomeTerm t) = hashWithSalt s t 45 | 46 | instance Show SomeTerm where 47 | show (SomeTerm (t :: Term a)) = 48 | "<<" ++ show t ++ " :: " ++ show (primTypeRep @a) ++ ">>" 49 | 50 | -- | Wrap a symbolic term into t'SomeTerm'. 51 | someTerm :: Term a -> SomeTerm 52 | someTerm v@SupportedTerm = SomeTerm v 53 | {-# INLINE someTerm #-} 54 | 55 | -- | Get the unique identifier of a symbolic term. 56 | someTermId :: SomeTerm -> Id 57 | someTermId (SomeTerm t) = termId t 58 | {-# INLINE someTermId #-} 59 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/Prim/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.SymPrim.Prim.Term 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.SymPrim.Prim.Term 12 | ( module Grisette.Internal.SymPrim.Prim.Internal.Term, 13 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm, 14 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm, 15 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm, 16 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm, 17 | module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm, 18 | ) 19 | where 20 | 21 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm () 22 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm 23 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP () 24 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm () 25 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm () 26 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm () 27 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm 28 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm () 29 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm 30 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm 31 | import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm 32 | import Grisette.Internal.SymPrim.Prim.Internal.Serialize () 33 | import Grisette.Internal.SymPrim.Prim.Internal.Term 34 | -------------------------------------------------------------------------------- /src/Grisette/Internal/SymPrim/SymPrim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | -- | 8 | -- Module : Grisette.Internal.SymPrim.SymPrim 9 | -- Copyright : (c) Sirui Lu 2024 10 | -- License : BSD-3-Clause (see the LICENSE file) 11 | -- 12 | -- Maintainer : siruilu@cs.washington.edu 13 | -- Stability : Experimental 14 | -- Portability : GHC only 15 | module Grisette.Internal.SymPrim.SymPrim (Prim, SymPrim, BasicSymPrim) where 16 | 17 | import Control.DeepSeq (NFData) 18 | import Data.Binary (Binary) 19 | import Data.Bytes.Serial (Serial) 20 | import Data.Serialize (Serialize) 21 | import Grisette.Internal.Core.Data.Class.AsKey (KeyEq, KeyHashable) 22 | import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) 23 | import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) 24 | import Grisette.Internal.Core.Data.Class.Function (Apply (FunType)) 25 | import Grisette.Internal.Core.Data.Class.GenSym (GenSymSimple) 26 | import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) 27 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 28 | import Grisette.Internal.Core.Data.Class.SimpleMergeable (SimpleMergeable) 29 | import Grisette.Internal.Core.Data.Class.Solvable (Solvable) 30 | import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) 31 | import Grisette.Internal.Core.Data.Class.ToCon (ToCon) 32 | import Grisette.Internal.Core.Data.Class.ToSym (ToSym) 33 | import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint (PPrint) 34 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq (SymEq) 35 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd (SymOrd) 36 | import Grisette.Internal.SymPrim.AllSyms (AllSyms) 37 | import Grisette.Internal.SymPrim.Prim.Internal.Term 38 | ( ConRep (ConType), 39 | LinkedRep, 40 | SupportedNonFuncPrim, 41 | ) 42 | import Language.Haskell.TH.Syntax (Lift) 43 | import Type.Reflection (Typeable) 44 | 45 | -- | A type that is used as a constraint for all the primitive types (including 46 | -- concrete primitives) in Grisette. 47 | type Prim a = 48 | ( Show a, 49 | Binary a, 50 | Serial a, 51 | Serialize a, 52 | NFData a, 53 | Eq a, 54 | EvalSym a, 55 | ExtractSym a, 56 | Mergeable a, 57 | PPrint a, 58 | SubstSym a, 59 | SymEq a, 60 | SymOrd a, 61 | AllSyms a, 62 | KeyEq a, 63 | KeyHashable a, 64 | Lift a, 65 | Typeable a 66 | ) 67 | 68 | -- | A type that is used as a constraint for all the symbolic primitive types 69 | -- in Grisette. 70 | type SymPrim a = 71 | ( Prim a, 72 | ITEOp a, 73 | GenSymSimple a a 74 | ) 75 | 76 | -- | A type that is used as a constraint for all the basic symbolic primitive 77 | -- types in Grisette. 78 | -- 79 | -- 'Grisette.SymPrim.SomeSymWordN' is not considered as a basic symbolic 80 | -- primitive type. 81 | type BasicSymPrim a = 82 | ( SymPrim a, 83 | SimpleMergeable a, 84 | GenSymSimple () a, 85 | Solvable (ConType a) a, 86 | ConRep a, 87 | LinkedRep (ConType a) a, 88 | ToCon a (ConType a), 89 | ToSym (ConType a) a, 90 | Apply a, 91 | a ~ FunType a, 92 | SupportedNonFuncPrim (ConType a) 93 | ) 94 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Ctor/Common.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Internal.TH.Ctor.Common 3 | -- Copyright : (c) Sirui Lu 2024 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Internal.TH.Ctor.Common 10 | ( withNameTransformer, 11 | prefixTransformer, 12 | decapitalizeTransformer, 13 | ) 14 | where 15 | 16 | import Control.Monad (unless) 17 | import Data.Char (isAlphaNum, toLower) 18 | import Data.Foldable (traverse_) 19 | import Language.Haskell.TH (Dec, Name, Q, nameBase) 20 | import Language.Haskell.TH.Datatype 21 | ( ConstructorInfo (constructorName), 22 | DatatypeInfo (datatypeCons), 23 | reifyDatatype, 24 | ) 25 | 26 | checkName :: String -> Q () 27 | checkName name = 28 | unless (all (\x -> isAlphaNum x || x == '\'' || x == '_') name) $ 29 | fail 30 | ( "Constructor name contain invalid characters, consider providing a " 31 | ++ "custom name: " 32 | ++ show name 33 | ) 34 | 35 | -- | Generate smart constructor given a type name, using a name transformer 36 | -- to transform constructor names. 37 | withNameTransformer :: 38 | -- | A function that generates decs given a list of constructor names and a 39 | -- type name 40 | ([String] -> Name -> Q [Dec]) -> 41 | -- | A function that transforms constructor names 42 | (String -> String) -> 43 | -- | The type to generate the wrappers for 44 | Name -> 45 | Q [Dec] 46 | withNameTransformer namedGen nameTransformer typName = do 47 | d <- reifyDatatype typName 48 | let constructorNames = nameBase . constructorName <$> datatypeCons d 49 | let transformedNames = nameTransformer <$> constructorNames 50 | traverse_ checkName transformedNames 51 | namedGen transformedNames typName 52 | 53 | -- | A name transformer that prefixes a string to the constructor name 54 | prefixTransformer :: String -> String -> String 55 | prefixTransformer = (++) 56 | 57 | -- | A name transformer that converts the first character to lowercase 58 | decapitalizeTransformer :: String -> String 59 | decapitalizeTransformer (x : xs) = toLower x : xs 60 | decapitalizeTransformer [] = [] 61 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveAllSyms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 3 | 4 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 5 | 6 | -- | 7 | -- Module : Grisette.Internal.TH.Derivation.DeriveAllSyms 8 | -- Copyright : (c) Sirui Lu 2024 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Internal.TH.Derivation.DeriveAllSyms 15 | ( deriveAllSyms, 16 | deriveAllSyms1, 17 | deriveAllSyms2, 18 | ) 19 | where 20 | 21 | import Grisette.Internal.Internal.Decl.SymPrim.AllSyms 22 | ( AllSyms (allSymsS), 23 | AllSyms1 (liftAllSymsS), 24 | AllSyms2 (liftAllSymsS2), 25 | ) 26 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 27 | import Grisette.Internal.TH.Derivation.UnaryOpCommon 28 | ( UnaryOpClassConfig 29 | ( UnaryOpClassConfig, 30 | unaryOpAllowExistential, 31 | unaryOpConfigs, 32 | unaryOpContextNames, 33 | unaryOpExtraVars, 34 | unaryOpInstanceNames, 35 | unaryOpInstanceTypeFromConfig 36 | ), 37 | UnaryOpConfig (UnaryOpConfig), 38 | UnaryOpFieldConfig 39 | ( UnaryOpFieldConfig, 40 | extraLiftedPatNames, 41 | extraPatNames, 42 | fieldCombineFun, 43 | fieldFunExp, 44 | fieldResFun 45 | ), 46 | defaultFieldFunExp, 47 | defaultFieldResFun, 48 | defaultUnaryOpInstanceTypeFromConfig, 49 | genUnaryOpClass, 50 | ) 51 | import Language.Haskell.TH (Dec, Exp (AppE, ListE, VarE), Name, Q) 52 | 53 | allSymsConfig :: UnaryOpClassConfig 54 | allSymsConfig = 55 | UnaryOpClassConfig 56 | { unaryOpConfigs = 57 | [ UnaryOpConfig 58 | UnaryOpFieldConfig 59 | { extraPatNames = [], 60 | extraLiftedPatNames = const [], 61 | fieldResFun = defaultFieldResFun, 62 | fieldCombineFun = \_ _ _ _ _ exp -> 63 | return (AppE (VarE 'mconcat) $ ListE exp, False <$ exp), 64 | fieldFunExp = 65 | defaultFieldFunExp 66 | [ 'allSymsS, 67 | 'liftAllSymsS, 68 | 'liftAllSymsS2 69 | ] 70 | } 71 | ['allSymsS, 'liftAllSymsS, 'liftAllSymsS2] 72 | ], 73 | unaryOpInstanceNames = [''AllSyms, ''AllSyms1, ''AllSyms2], 74 | unaryOpExtraVars = const $ return [], 75 | unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, 76 | unaryOpAllowExistential = True, 77 | unaryOpContextNames = Nothing 78 | } 79 | 80 | -- | Derive 'AllSyms' instance for a data type. 81 | deriveAllSyms :: DeriveConfig -> Name -> Q [Dec] 82 | deriveAllSyms deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 0 83 | 84 | -- | Derive 'AllSyms1' instance for a data type. 85 | deriveAllSyms1 :: DeriveConfig -> Name -> Q [Dec] 86 | deriveAllSyms1 deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 1 87 | 88 | -- | Derive 'AllSyms2' instance for a data type. 89 | deriveAllSyms2 :: DeriveConfig -> Name -> Q [Dec] 90 | deriveAllSyms2 deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 2 91 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveBinary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 5 | 6 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 7 | 8 | -- | 9 | -- Module : Grisette.Internal.TH.Derivation.DeriveBinary 10 | -- Copyright : (c) Sirui Lu 2024 11 | -- License : BSD-3-Clause (see the LICENSE file) 12 | -- 13 | -- Maintainer : siruilu@cs.washington.edu 14 | -- Stability : Experimental 15 | -- Portability : GHC only 16 | module Grisette.Internal.TH.Derivation.DeriveBinary (deriveBinary) where 17 | 18 | import Data.Binary (Binary (get, put)) 19 | import Grisette.Internal.TH.Derivation.Common 20 | ( DeriveConfig (useSerialForCerealAndBinary), 21 | ) 22 | import Grisette.Internal.TH.Derivation.SerializeCommon 23 | ( serializeConfig, 24 | serializeWithSerialConfig, 25 | ) 26 | import Grisette.Internal.TH.Derivation.UnaryOpCommon 27 | ( UnaryOpClassConfig, 28 | genUnaryOpClass, 29 | ) 30 | import Language.Haskell.TH (Dec, Name, Q) 31 | 32 | binaryConfig :: UnaryOpClassConfig 33 | binaryConfig = serializeConfig [''Binary] ['put] ['get] 34 | 35 | binaryWithSerialConfig :: UnaryOpClassConfig 36 | binaryWithSerialConfig = 37 | serializeWithSerialConfig [''Binary] ['put] ['get] 38 | 39 | -- | Derive 'Binary' instance for a data type. 40 | deriveBinary :: DeriveConfig -> Name -> Q [Dec] 41 | deriveBinary deriveConfig = 42 | genUnaryOpClass 43 | deriveConfig 44 | ( if useSerialForCerealAndBinary deriveConfig 45 | then binaryWithSerialConfig 46 | else binaryConfig 47 | ) 48 | 0 49 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveCereal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 5 | 6 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 7 | 8 | -- | 9 | -- Module : Grisette.Internal.TH.Derivation.DeriveCereal 10 | -- Copyright : (c) Sirui Lu 2024 11 | -- License : BSD-3-Clause (see the LICENSE file) 12 | -- 13 | -- Maintainer : siruilu@cs.washington.edu 14 | -- Stability : Experimental 15 | -- Portability : GHC only 16 | module Grisette.Internal.TH.Derivation.DeriveCereal (deriveCereal) where 17 | 18 | import Data.Serialize (Serialize (get, put)) 19 | import Grisette.Internal.TH.Derivation.Common 20 | ( DeriveConfig (useSerialForCerealAndBinary), 21 | ) 22 | import Grisette.Internal.TH.Derivation.SerializeCommon 23 | ( serializeConfig, 24 | serializeWithSerialConfig, 25 | ) 26 | import Grisette.Internal.TH.Derivation.UnaryOpCommon 27 | ( UnaryOpClassConfig, 28 | genUnaryOpClass, 29 | ) 30 | import Language.Haskell.TH (Dec, Name, Q) 31 | 32 | cerealConfig :: UnaryOpClassConfig 33 | cerealConfig = serializeConfig [''Serialize] ['put] ['get] 34 | 35 | cerealWithSerialConfig :: UnaryOpClassConfig 36 | cerealWithSerialConfig = 37 | serializeWithSerialConfig [''Serialize] ['put] ['get] 38 | 39 | -- | Derive 'Serialize' instance for a data type. 40 | deriveCereal :: DeriveConfig -> Name -> Q [Dec] 41 | deriveCereal deriveConfig = 42 | genUnaryOpClass 43 | deriveConfig 44 | ( if useSerialForCerealAndBinary deriveConfig 45 | then cerealWithSerialConfig 46 | else cerealConfig 47 | ) 48 | 0 49 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | -- | 6 | -- Module : Grisette.Internal.TH.Derivation.DeriveEq 7 | -- Copyright : (c) Sirui Lu 2024 8 | -- License : BSD-3-Clause (see the LICENSE file) 9 | -- 10 | -- Maintainer : siruilu@cs.washington.edu 11 | -- Stability : Experimental 12 | -- Portability : GHC only 13 | module Grisette.Internal.TH.Derivation.DeriveEq 14 | ( deriveEq, 15 | deriveEq1, 16 | deriveEq2, 17 | ) 18 | where 19 | 20 | import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2)) 21 | import Grisette.Internal.TH.Derivation.BinaryOpCommon 22 | ( BinaryOpClassConfig 23 | ( BinaryOpClassConfig, 24 | binaryOpAllowSumType, 25 | binaryOpFieldConfigs, 26 | binaryOpInstanceNames 27 | ), 28 | BinaryOpFieldConfig 29 | ( BinaryOpFieldConfig, 30 | extraPatNames, 31 | fieldCombineFun, 32 | fieldDifferentExistentialFun, 33 | fieldFunExp, 34 | fieldFunNames, 35 | fieldLMatchResult, 36 | fieldRMatchResult, 37 | fieldResFun 38 | ), 39 | binaryOpAllowExistential, 40 | defaultFieldFunExp, 41 | genBinaryOpClass, 42 | ) 43 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 44 | import Language.Haskell.TH (Dec, Exp (ListE), Q) 45 | import Language.Haskell.TH.Syntax (Name) 46 | 47 | eqConfig :: BinaryOpClassConfig 48 | eqConfig = 49 | BinaryOpClassConfig 50 | { binaryOpFieldConfigs = 51 | [ BinaryOpFieldConfig 52 | { extraPatNames = [], 53 | fieldResFun = \_ (lhs, rhs) f -> 54 | (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], 55 | fieldCombineFun = \_ lst -> 56 | (,[]) <$> [|and $(return $ ListE lst)|], 57 | fieldDifferentExistentialFun = const [|False|], 58 | fieldFunExp = defaultFieldFunExp ['(==), 'liftEq, 'liftEq2], 59 | fieldFunNames = ['(==), 'liftEq, 'liftEq2], 60 | fieldLMatchResult = [|False|], 61 | fieldRMatchResult = [|False|] 62 | } 63 | ], 64 | binaryOpInstanceNames = [''Eq, ''Eq1, ''Eq2], 65 | binaryOpAllowSumType = True, 66 | binaryOpAllowExistential = True 67 | } 68 | 69 | -- | Derive 'Eq' instance for a data type. 70 | deriveEq :: DeriveConfig -> Name -> Q [Dec] 71 | deriveEq deriveConfig = genBinaryOpClass deriveConfig eqConfig 0 72 | 73 | -- | Derive 'Eq1' instance for a data type. 74 | deriveEq1 :: DeriveConfig -> Name -> Q [Dec] 75 | deriveEq1 deriveConfig = genBinaryOpClass deriveConfig eqConfig 1 76 | 77 | -- | Derive 'Eq2' instance for a data type. 78 | deriveEq2 :: DeriveConfig -> Name -> Q [Dec] 79 | deriveEq2 deriveConfig = genBinaryOpClass deriveConfig eqConfig 2 80 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveNFData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.TH.Derivation.DeriveNFData 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.TH.Derivation.DeriveNFData 12 | ( deriveNFData, 13 | deriveNFData1, 14 | deriveNFData2, 15 | ) 16 | where 17 | 18 | import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), NFData2 (liftRnf2)) 19 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 20 | import Grisette.Internal.TH.Derivation.UnaryOpCommon 21 | ( UnaryOpClassConfig 22 | ( UnaryOpClassConfig, 23 | unaryOpAllowExistential, 24 | unaryOpConfigs, 25 | unaryOpContextNames, 26 | unaryOpExtraVars, 27 | unaryOpInstanceNames, 28 | unaryOpInstanceTypeFromConfig 29 | ), 30 | UnaryOpConfig (UnaryOpConfig), 31 | UnaryOpFieldConfig 32 | ( UnaryOpFieldConfig, 33 | extraLiftedPatNames, 34 | extraPatNames, 35 | fieldCombineFun, 36 | fieldFunExp, 37 | fieldResFun 38 | ), 39 | defaultFieldFunExp, 40 | defaultFieldResFun, 41 | defaultUnaryOpInstanceTypeFromConfig, 42 | genUnaryOpClass, 43 | ) 44 | import Language.Haskell.TH (Dec, Name) 45 | import Language.Haskell.TH.Syntax (Q) 46 | 47 | nfdataConfig :: UnaryOpClassConfig 48 | nfdataConfig = 49 | UnaryOpClassConfig 50 | { unaryOpConfigs = 51 | [ UnaryOpConfig 52 | UnaryOpFieldConfig 53 | { extraPatNames = [], 54 | extraLiftedPatNames = const [], 55 | fieldCombineFun = \_ _ _ _ _ exps -> do 56 | r <- 57 | foldl 58 | (\acc exp -> [|$acc `seq` $(return exp)|]) 59 | ([|()|]) 60 | exps 61 | return (r, []), 62 | fieldResFun = defaultFieldResFun, 63 | fieldFunExp = defaultFieldFunExp ['rnf, 'liftRnf, 'liftRnf2] 64 | } 65 | ['rnf, 'liftRnf, 'liftRnf2] 66 | ], 67 | unaryOpInstanceNames = [''NFData, ''NFData1, ''NFData2], 68 | unaryOpExtraVars = const $ return [], 69 | unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, 70 | unaryOpAllowExistential = True, 71 | unaryOpContextNames = Nothing 72 | } 73 | 74 | -- | Derive 'NFData' instance for a data type. 75 | deriveNFData :: DeriveConfig -> Name -> Q [Dec] 76 | deriveNFData deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 0 77 | 78 | -- | Derive 'NFData1' instance for a data type. 79 | deriveNFData1 :: DeriveConfig -> Name -> Q [Dec] 80 | deriveNFData1 deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 1 81 | 82 | -- | Derive 'NFData2' instance for a data type. 83 | deriveNFData2 :: DeriveConfig -> Name -> Q [Dec] 84 | deriveNFData2 deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 2 85 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveOrd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | -- | 5 | -- Module : Grisette.Internal.TH.Derivation.DeriveOrd 6 | -- Copyright : (c) Sirui Lu 2024 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Internal.TH.Derivation.DeriveOrd 13 | ( deriveOrd, 14 | deriveOrd1, 15 | deriveOrd2, 16 | ) 17 | where 18 | 19 | import Data.Functor.Classes (Ord1 (liftCompare), Ord2 (liftCompare2)) 20 | import Grisette.Internal.TH.Derivation.BinaryOpCommon 21 | ( BinaryOpClassConfig 22 | ( BinaryOpClassConfig, 23 | binaryOpAllowSumType, 24 | binaryOpFieldConfigs, 25 | binaryOpInstanceNames 26 | ), 27 | BinaryOpFieldConfig 28 | ( BinaryOpFieldConfig, 29 | extraPatNames, 30 | fieldCombineFun, 31 | fieldDifferentExistentialFun, 32 | fieldFunExp, 33 | fieldFunNames, 34 | fieldLMatchResult, 35 | fieldRMatchResult, 36 | fieldResFun 37 | ), 38 | binaryOpAllowExistential, 39 | defaultFieldFunExp, 40 | genBinaryOpClass, 41 | ) 42 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 43 | import Language.Haskell.TH (Dec, Exp (ListE), Name, Q) 44 | 45 | ordConfig :: BinaryOpClassConfig 46 | ordConfig = 47 | BinaryOpClassConfig 48 | { binaryOpFieldConfigs = 49 | [ BinaryOpFieldConfig 50 | { extraPatNames = [], 51 | fieldResFun = \_ (lhs, rhs) f -> 52 | (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], 53 | fieldCombineFun = \_ lst -> 54 | (,[]) <$> [|mconcat $(return $ ListE lst)|], 55 | fieldDifferentExistentialFun = return, 56 | fieldFunExp = 57 | defaultFieldFunExp ['compare, 'liftCompare, 'liftCompare2], 58 | fieldFunNames = ['compare, 'liftCompare, 'liftCompare2], 59 | fieldLMatchResult = [|LT|], 60 | fieldRMatchResult = [|GT|] 61 | } 62 | ], 63 | binaryOpInstanceNames = [''Ord, ''Ord1, ''Ord2], 64 | binaryOpAllowSumType = True, 65 | binaryOpAllowExistential = True 66 | } 67 | 68 | -- | Derive 'Ord' instance for a data type. 69 | deriveOrd :: DeriveConfig -> Name -> Q [Dec] 70 | deriveOrd deriveConfig = genBinaryOpClass deriveConfig ordConfig 0 71 | 72 | -- | Derive 'Ord1' instance for a data type. 73 | deriveOrd1 :: DeriveConfig -> Name -> Q [Dec] 74 | deriveOrd1 deriveConfig = genBinaryOpClass deriveConfig ordConfig 1 75 | 76 | -- | Derive 'Ord2' instance for a data type. 77 | deriveOrd2 :: DeriveConfig -> Name -> Q [Dec] 78 | deriveOrd2 deriveConfig = genBinaryOpClass deriveConfig ordConfig 2 79 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveSerial.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 5 | 6 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 7 | 8 | -- | 9 | -- Module : Grisette.Internal.TH.Derivation.DeriveSerial 10 | -- Copyright : (c) Sirui Lu 2024 11 | -- License : BSD-3-Clause (see the LICENSE file) 12 | -- 13 | -- Maintainer : siruilu@cs.washington.edu 14 | -- Stability : Experimental 15 | -- Portability : GHC only 16 | module Grisette.Internal.TH.Derivation.DeriveSerial 17 | ( deriveSerial, 18 | deriveSerial1, 19 | deriveSerial2, 20 | ) 21 | where 22 | 23 | import Data.Bytes.Serial 24 | ( Serial (deserialize, serialize), 25 | Serial1 (deserializeWith, serializeWith), 26 | Serial2 (deserializeWith2, serializeWith2), 27 | ) 28 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 29 | import Grisette.Internal.TH.Derivation.SerializeCommon (serializeConfig) 30 | import Grisette.Internal.TH.Derivation.UnaryOpCommon 31 | ( UnaryOpClassConfig, 32 | genUnaryOpClass, 33 | ) 34 | import Language.Haskell.TH (Dec, Name, Q) 35 | 36 | serialConfig :: UnaryOpClassConfig 37 | serialConfig = 38 | serializeConfig 39 | [''Serial, ''Serial1, ''Serial2] 40 | ['serialize, 'serializeWith, 'serializeWith2] 41 | ['deserialize, 'deserializeWith, 'deserializeWith2] 42 | 43 | -- | Derive 'Serial' instance for a data type. 44 | deriveSerial :: DeriveConfig -> Name -> Q [Dec] 45 | deriveSerial deriveConfig = genUnaryOpClass deriveConfig serialConfig 0 46 | 47 | -- | Derive 'Serial1' instance for a data type. 48 | deriveSerial1 :: DeriveConfig -> Name -> Q [Dec] 49 | deriveSerial1 deriveConfig = genUnaryOpClass deriveConfig serialConfig 1 50 | 51 | -- | Derive 'Serial2' instance for a data type. 52 | deriveSerial2 :: DeriveConfig -> Name -> Q [Dec] 53 | deriveSerial2 deriveConfig = genUnaryOpClass deriveConfig serialConfig 2 54 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveSubstSym.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 3 | 4 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 5 | 6 | -- | 7 | -- Module : Grisette.Internal.TH.Derivation.DeriveSubstSym 8 | -- Copyright : (c) Sirui Lu 2024 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Internal.TH.Derivation.DeriveSubstSym 15 | ( deriveSubstSym, 16 | deriveSubstSym1, 17 | deriveSubstSym2, 18 | ) 19 | where 20 | 21 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym 22 | ( SubstSym (substSym), 23 | SubstSym1 (liftSubstSym), 24 | SubstSym2 (liftSubstSym2), 25 | ) 26 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 27 | import Grisette.Internal.TH.Derivation.UnaryOpCommon 28 | ( UnaryOpClassConfig 29 | ( UnaryOpClassConfig, 30 | unaryOpAllowExistential, 31 | unaryOpConfigs, 32 | unaryOpContextNames, 33 | unaryOpExtraVars, 34 | unaryOpInstanceNames, 35 | unaryOpInstanceTypeFromConfig 36 | ), 37 | UnaryOpConfig (UnaryOpConfig), 38 | UnaryOpFieldConfig 39 | ( UnaryOpFieldConfig, 40 | extraLiftedPatNames, 41 | extraPatNames, 42 | fieldCombineFun, 43 | fieldFunExp, 44 | fieldResFun 45 | ), 46 | defaultFieldFunExp, 47 | defaultFieldResFun, 48 | defaultUnaryOpInstanceTypeFromConfig, 49 | genUnaryOpClass, 50 | ) 51 | import Language.Haskell.TH (Dec, Exp (AppE, ConE), Name) 52 | import Language.Haskell.TH.Syntax (Q) 53 | 54 | substSymConfig :: UnaryOpClassConfig 55 | substSymConfig = 56 | UnaryOpClassConfig 57 | { unaryOpConfigs = 58 | [ UnaryOpConfig 59 | UnaryOpFieldConfig 60 | { extraPatNames = ["symbol", "newVal"], 61 | extraLiftedPatNames = const [], 62 | fieldResFun = defaultFieldResFun, 63 | fieldCombineFun = \_ _ _ con extraPat exp -> 64 | return (foldl AppE (ConE con) exp, False <$ extraPat), 65 | fieldFunExp = 66 | defaultFieldFunExp 67 | ['substSym, 'liftSubstSym, 'liftSubstSym2] 68 | } 69 | ['substSym, 'liftSubstSym, 'liftSubstSym2] 70 | ], 71 | unaryOpInstanceNames = 72 | [''SubstSym, ''SubstSym1, ''SubstSym2], 73 | unaryOpExtraVars = const $ return [], 74 | unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig, 75 | unaryOpAllowExistential = True, 76 | unaryOpContextNames = Nothing 77 | } 78 | 79 | -- | Derive 'SubstSym' instance for a data type. 80 | deriveSubstSym :: DeriveConfig -> Name -> Q [Dec] 81 | deriveSubstSym deriveConfig = genUnaryOpClass deriveConfig substSymConfig 0 82 | 83 | -- | Derive 'SubstSym1' instance for a data type. 84 | deriveSubstSym1 :: DeriveConfig -> Name -> Q [Dec] 85 | deriveSubstSym1 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 1 86 | 87 | -- | Derive 'SubstSym2' instance for a data type. 88 | deriveSubstSym2 :: DeriveConfig -> Name -> Q [Dec] 89 | deriveSubstSym2 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 2 90 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveSymEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | -- | 5 | -- Module : Grisette.Internal.TH.Derivation.DeriveSymEq 6 | -- Copyright : (c) Sirui Lu 2024 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Internal.TH.Derivation.DeriveSymEq 13 | ( deriveSymEq, 14 | deriveSymEq1, 15 | deriveSymEq2, 16 | ) 17 | where 18 | 19 | import Grisette.Internal.Core.Data.Class.LogicalOp 20 | ( LogicalOp (false, true, (.&&)), 21 | ) 22 | import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq 23 | ( SymEq ((.==)), 24 | SymEq1 (liftSymEq), 25 | SymEq2 (liftSymEq2), 26 | ) 27 | import Grisette.Internal.TH.Derivation.BinaryOpCommon 28 | ( BinaryOpClassConfig 29 | ( BinaryOpClassConfig, 30 | binaryOpAllowSumType, 31 | binaryOpFieldConfigs, 32 | binaryOpInstanceNames 33 | ), 34 | BinaryOpFieldConfig 35 | ( BinaryOpFieldConfig, 36 | extraPatNames, 37 | fieldCombineFun, 38 | fieldDifferentExistentialFun, 39 | fieldFunExp, 40 | fieldFunNames, 41 | fieldLMatchResult, 42 | fieldRMatchResult, 43 | fieldResFun 44 | ), 45 | binaryOpAllowExistential, 46 | defaultFieldFunExp, 47 | genBinaryOpClass, 48 | ) 49 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 50 | import Language.Haskell.TH (Dec, Exp (ListE), Name, Q) 51 | 52 | symEqConfig :: BinaryOpClassConfig 53 | symEqConfig = 54 | BinaryOpClassConfig 55 | { binaryOpFieldConfigs = 56 | [ BinaryOpFieldConfig 57 | { extraPatNames = [], 58 | fieldResFun = \_ (lhs, rhs) f -> 59 | (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|], 60 | fieldCombineFun = 61 | \_ lst -> (,[]) <$> [|foldl (.&&) true $(return $ ListE lst)|], 62 | fieldDifferentExistentialFun = const [|false|], 63 | fieldFunExp = 64 | defaultFieldFunExp ['(.==), 'liftSymEq, 'liftSymEq2], 65 | fieldFunNames = ['(.==), 'liftSymEq, 'liftSymEq2], 66 | fieldLMatchResult = [|false|], 67 | fieldRMatchResult = [|false|] 68 | } 69 | ], 70 | binaryOpInstanceNames = [''SymEq, ''SymEq1, ''SymEq2], 71 | binaryOpAllowSumType = True, 72 | binaryOpAllowExistential = True 73 | } 74 | 75 | -- | Derive 'SymEq' instance for a data type. 76 | deriveSymEq :: DeriveConfig -> Name -> Q [Dec] 77 | deriveSymEq deriveConfig = genBinaryOpClass deriveConfig symEqConfig 0 78 | 79 | -- | Derive 'SymEq1' instance for a data type. 80 | deriveSymEq1 :: DeriveConfig -> Name -> Q [Dec] 81 | deriveSymEq1 deriveConfig = genBinaryOpClass deriveConfig symEqConfig 1 82 | 83 | -- | Derive 'SymEq2' instance for a data type. 84 | deriveSymEq2 :: DeriveConfig -> Name -> Q [Dec] 85 | deriveSymEq2 deriveConfig = genBinaryOpClass deriveConfig symEqConfig 2 86 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveToCon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.TH.Derivation.DeriveToCon 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.TH.Derivation.DeriveToCon 12 | ( deriveToCon, 13 | deriveToCon1, 14 | deriveToCon2, 15 | ) 16 | where 17 | 18 | import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon 19 | ( ToCon (toCon), 20 | ToCon1 (liftToCon), 21 | ToCon2 (liftToCon2), 22 | ) 23 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 24 | import Grisette.Internal.TH.Derivation.ConvertOpCommon 25 | ( ConvertOpClassConfig 26 | ( ConvertOpClassConfig, 27 | convertFieldCombineFun, 28 | convertFieldFunExp, 29 | convertFieldResFun, 30 | convertOpFunNames, 31 | convertOpInstanceNames, 32 | convertOpTarget 33 | ), 34 | defaultFieldFunExp, 35 | genConvertOpClass, 36 | ) 37 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C)) 38 | import Language.Haskell.TH (Dec, Name, Q, conE) 39 | 40 | toConClassConfig :: ConvertOpClassConfig 41 | toConClassConfig = 42 | ConvertOpClassConfig 43 | { convertFieldResFun = \v f -> [|$(return f) $(return v)|], 44 | convertFieldCombineFun = \f args -> 45 | foldl 46 | (\acc arg -> [|$(acc) <*> $arg|]) 47 | [|return $(conE f)|] 48 | $ fmap return args, 49 | convertFieldFunExp = defaultFieldFunExp ['toCon, 'liftToCon, 'liftToCon2], 50 | convertOpTarget = C, 51 | convertOpInstanceNames = [''ToCon, ''ToCon1, ''ToCon2], 52 | convertOpFunNames = ['toCon, 'liftToCon, 'liftToCon2] 53 | } 54 | 55 | -- | Derive 'ToCon' instance for a data type. 56 | deriveToCon :: DeriveConfig -> Name -> Q [Dec] 57 | deriveToCon deriveConfig = genConvertOpClass deriveConfig toConClassConfig 0 58 | 59 | -- | Derive 'ToCon1' instance for a data type. 60 | deriveToCon1 :: DeriveConfig -> Name -> Q [Dec] 61 | deriveToCon1 deriveConfig = 62 | genConvertOpClass deriveConfig toConClassConfig 1 63 | 64 | -- | Derive 'ToCon2' instance for a data type. 65 | deriveToCon2 :: DeriveConfig -> Name -> Q [Dec] 66 | deriveToCon2 deriveConfig = 67 | genConvertOpClass deriveConfig toConClassConfig 2 68 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/DeriveToSym.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 3 | 4 | {-# HLINT ignore "Unused LANGUAGE pragma" #-} 5 | 6 | -- | 7 | -- Module : Grisette.Internal.TH.Derivation.DeriveToSym 8 | -- Copyright : (c) Sirui Lu 2024 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Internal.TH.Derivation.DeriveToSym 15 | ( deriveToSym, 16 | deriveToSym1, 17 | deriveToSym2, 18 | ) 19 | where 20 | 21 | import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym 22 | ( ToSym (toSym), 23 | ToSym1 (liftToSym), 24 | ToSym2 (liftToSym2), 25 | ) 26 | import Grisette.Internal.TH.Derivation.Common (DeriveConfig) 27 | import Grisette.Internal.TH.Derivation.ConvertOpCommon 28 | ( ConvertOpClassConfig 29 | ( ConvertOpClassConfig, 30 | convertFieldCombineFun, 31 | convertFieldFunExp, 32 | convertFieldResFun, 33 | convertOpInstanceNames, 34 | convertOpTarget 35 | ), 36 | convertOpFunNames, 37 | defaultFieldFunExp, 38 | genConvertOpClass, 39 | ) 40 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) 41 | import Language.Haskell.TH (Dec, Name, Q, appE, conE) 42 | 43 | toSymClassConfig :: ConvertOpClassConfig 44 | toSymClassConfig = 45 | ConvertOpClassConfig 46 | { convertFieldResFun = \v f -> [|$(return f) $(return v)|], 47 | convertFieldCombineFun = 48 | \f args -> foldl appE (conE f) $ fmap return args, 49 | convertFieldFunExp = defaultFieldFunExp ['toSym, 'liftToSym, 'liftToSym2], 50 | convertOpTarget = S, 51 | convertOpInstanceNames = [''ToSym, ''ToSym1, ''ToSym2], 52 | convertOpFunNames = ['toSym, 'liftToSym, 'liftToSym2] 53 | } 54 | 55 | -- | Derive 'ToSym' instance for a data type. 56 | deriveToSym :: DeriveConfig -> Name -> Q [Dec] 57 | deriveToSym deriveConfig = genConvertOpClass deriveConfig toSymClassConfig 0 58 | 59 | -- | Derive 'ToSym1' instance for a data type. 60 | deriveToSym1 :: DeriveConfig -> Name -> Q [Dec] 61 | deriveToSym1 deriveConfig = 62 | genConvertOpClass deriveConfig toSymClassConfig 1 63 | 64 | -- | Derive 'ToSym2' instance for a data type. 65 | deriveToSym2 :: DeriveConfig -> Name -> Q [Dec] 66 | deriveToSym2 deriveConfig = 67 | genConvertOpClass deriveConfig toSymClassConfig 2 68 | -------------------------------------------------------------------------------- /src/Grisette/Internal/TH/Derivation/ShowPPrintCommon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.TH.Derivation.ShowPPrintCommon 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.TH.Derivation.ShowPPrintCommon (showPrintFieldFunExp) where 12 | 13 | import qualified Data.Map as M 14 | import qualified Data.Set as S 15 | import Grisette.Internal.TH.Derivation.UnaryOpCommon (FieldFunExp) 16 | import Language.Haskell.TH (Name, Type (AppT, VarT), varE) 17 | import Language.Haskell.TH.Datatype (TypeSubstitution (freeVariables)) 18 | 19 | -- | Common 'FieldFunExp' for 'Show' and 'Grisette.Core.PPrint' on a GADT. 20 | showPrintFieldFunExp :: [Name] -> [Name] -> FieldFunExp 21 | showPrintFieldFunExp precNames listNames argToFunPat liftedExps = go 22 | where 23 | allArgNames = M.keysSet argToFunPat 24 | typeHasNoArg ty = 25 | S.fromList (freeVariables [ty]) 26 | `S.intersection` allArgNames 27 | == S.empty 28 | goLst ty = do 29 | let fun0 = varE (head listNames) 30 | fun1 b = [|$(varE $ listNames !! 1) $(go b) $(goLst b)|] 31 | fun2 b c = 32 | [|$(varE $ listNames !! 2) $(go b) $(goLst b) $(go c) $(goLst c)|] 33 | case ty of 34 | AppT (AppT (VarT _) b) c -> fun2 b c 35 | AppT (VarT _) b -> fun1 b 36 | _ | typeHasNoArg ty -> fun0 37 | AppT a b | typeHasNoArg a -> fun1 b 38 | AppT (AppT a b) c | typeHasNoArg a -> fun2 b c 39 | VarT nm -> case M.lookup nm liftedExps of 40 | Just [p] -> varE p 41 | _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty 42 | _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty 43 | go ty = do 44 | let fun0 = varE (head precNames) 45 | fun1 b = [|$(varE $ precNames !! 1) $(go b) $(goLst b)|] 46 | fun2 b c = 47 | [|$(varE $ precNames !! 2) $(go b) $(goLst b) $(go c) $(goLst c)|] 48 | case ty of 49 | AppT (AppT (VarT _) b) c -> fun2 b c 50 | AppT (VarT _) b -> fun1 b 51 | _ | typeHasNoArg ty -> fun0 52 | AppT a b | typeHasNoArg a -> fun1 b 53 | AppT (AppT a b) c | typeHasNoArg a -> fun2 b c 54 | VarT nm -> case M.lookup nm argToFunPat of 55 | Just pname -> varE pname 56 | _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty 57 | _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty 58 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/BVFPConversion.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.BVFPConversion 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.BVFPConversion 12 | ( UnifiedBVFPConversion, 13 | SafeUnifiedBVFPConversion, 14 | AllUnifiedBVFPConversion, 15 | ) 16 | where 17 | 18 | import Grisette.Internal.Internal.Decl.Unified.BVFPConversion 19 | import Grisette.Internal.Internal.Impl.Unified.BVFPConversion () 20 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/BaseConstraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.EvaluationMode 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.BaseConstraint 12 | ( ConSymConversion, 13 | ) 14 | where 15 | 16 | import Grisette.Internal.Core.Data.Class.ToCon (ToCon) 17 | import Grisette.Internal.Core.Data.Class.ToSym (ToSym) 18 | 19 | -- | A type that is used as a constraint for all the types in Grisette that can 20 | -- be converted between concrete and symbolic types. 21 | type ConSymConversion conType symType t = 22 | ( ToCon t conType, 23 | ToSym conType t, 24 | ToCon symType t, 25 | ToSym t symType 26 | ) 27 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Class/UnifiedITEOp.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.Class.UnifiedITEOp 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.Class.UnifiedITEOp 12 | ( symIte, 13 | symIteMerge, 14 | UnifiedITEOp (..), 15 | ) 16 | where 17 | 18 | import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp 19 | import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp 20 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Class/UnifiedSafeFdiv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 12 | 13 | {-# HLINT ignore "Eta reduce" #-} 14 | 15 | -- | 16 | -- Module : Grisette.Internal.Unified.Class.UnifiedSafeFdiv 17 | -- Copyright : (c) Sirui Lu 2024 18 | -- License : BSD-3-Clause (see the LICENSE file) 19 | -- 20 | -- Maintainer : siruilu@cs.washington.edu 21 | -- Stability : Experimental 22 | -- Portability : GHC only 23 | module Grisette.Internal.Unified.Class.UnifiedSafeFdiv 24 | ( safeFdiv, 25 | UnifiedSafeFdiv (..), 26 | ) 27 | where 28 | 29 | import Control.Exception (ArithException) 30 | import Control.Monad.Error.Class (MonadError) 31 | import Grisette.Internal.Core.Data.Class.SafeFdiv (SafeFdiv) 32 | import qualified Grisette.Internal.Core.Data.Class.SafeFdiv 33 | import Grisette.Internal.SymPrim.AlgReal (AlgReal) 34 | import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) 35 | import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable 36 | ( UnifiedBranching (withBaseBranching), 37 | ) 38 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S)) 39 | import Grisette.Internal.Unified.Util (withMode) 40 | 41 | -- | Unified `Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv` operation. 42 | -- 43 | -- This function isn't able to infer the mode, so you need to provide the mode 44 | -- explicitly. For example: 45 | -- 46 | -- > safeFdiv @mode a b 47 | safeFdiv :: 48 | forall mode e a m. 49 | (MonadError e m, UnifiedSafeFdiv mode e a m) => 50 | a -> 51 | a -> 52 | m a 53 | safeFdiv a b = 54 | withBaseUnifiedSafeFdiv @mode @e @a @m $ 55 | Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv a b 56 | {-# INLINE safeFdiv #-} 57 | 58 | -- | A class that provides unified floating division operations. 59 | -- 60 | -- We use this type class to help resolve the constraints for `SafeFdiv`. 61 | class UnifiedSafeFdiv (mode :: EvalModeTag) e a m where 62 | withBaseUnifiedSafeFdiv :: ((SafeFdiv e a m) => r) -> r 63 | 64 | instance 65 | {-# INCOHERENT #-} 66 | (UnifiedBranching mode m, SafeFdiv e a m) => 67 | UnifiedSafeFdiv mode e a m 68 | where 69 | withBaseUnifiedSafeFdiv r = r 70 | 71 | instance 72 | (MonadError ArithException m, UnifiedBranching mode m) => 73 | UnifiedSafeFdiv mode ArithException AlgReal m 74 | where 75 | withBaseUnifiedSafeFdiv r = 76 | withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) 77 | 78 | instance 79 | (MonadError ArithException m, UnifiedBranching 'S m) => 80 | UnifiedSafeFdiv 'S ArithException SymAlgReal m 81 | where 82 | withBaseUnifiedSafeFdiv r = withBaseBranching @'S @m r 83 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Class/UnifiedSimpleMergeable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.Class.UnifiedSimpleMergeable 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.Class.UnifiedSimpleMergeable 12 | ( UnifiedBranching (..), 13 | UnifiedSimpleMergeable (..), 14 | UnifiedSimpleMergeable1 (..), 15 | UnifiedSimpleMergeable2 (..), 16 | mrgIf, 17 | liftUnion, 18 | mrgIte, 19 | mrgIte1, 20 | liftMrgIte, 21 | mrgIte2, 22 | liftMrgIte2, 23 | simpleMerge, 24 | ) 25 | where 26 | 27 | import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable 28 | import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable 29 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Class/UnifiedSymEq.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.Class.UnifiedSymEq 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.Class.UnifiedSymEq 12 | ( UnifiedSymEq (..), 13 | UnifiedSymEq1 (..), 14 | UnifiedSymEq2 (..), 15 | (.==), 16 | (./=), 17 | symDistinct, 18 | liftSymEq, 19 | symEq1, 20 | liftSymEq2, 21 | symEq2, 22 | ) 23 | where 24 | 25 | import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq 26 | import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq 27 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Class/UnifiedSymOrd.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.Class.UnifiedSymOrd 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.Class.UnifiedSymOrd 12 | ( UnifiedSymOrd (..), 13 | UnifiedSymOrd1 (..), 14 | UnifiedSymOrd2 (..), 15 | (.<=), 16 | (.<), 17 | (.>=), 18 | (.>), 19 | symMax, 20 | symMin, 21 | mrgMax, 22 | mrgMin, 23 | ) 24 | where 25 | 26 | import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd 27 | import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd 28 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Class/UnionViewMode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | module Grisette.Internal.Unified.Class.UnionViewMode (UnionViewMode) where 6 | 7 | import Control.Monad.Identity (Identity) 8 | import Data.Kind (Type) 9 | import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union) 10 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 11 | 12 | -- | This class is used to determine the type of the Boolean used in the 13 | -- 'Grisette.Core.UnionView' class. 14 | -- 15 | -- For 'Identity', we use 'Bool' as the Boolean type, and this ensures that 16 | -- the 'Grisette.Core.ifView' function will return 'Nothing'. 17 | -- 18 | -- For 'Union', we use 'SymBool' as the Boolean type, and 'Grisette.Core.ifView' 19 | -- function can return 'Nothing' or 'Just'. 20 | class UnionViewMode (mode :: EvalModeTag) (u :: Type -> Type) | u -> mode 21 | 22 | instance UnionViewMode 'C Identity 23 | 24 | instance UnionViewMode 'S Union 25 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/EvalMode.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.EvalMode 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.EvalMode 12 | ( EvalModeBase, 13 | EvalModeInteger, 14 | EvalModeBV, 15 | EvalModeFP, 16 | EvalModeAlgReal, 17 | EvalModeAll, 18 | MonadEvalModeAll, 19 | genEvalMode, 20 | ) 21 | where 22 | 23 | import Grisette.Internal.Internal.Decl.Unified.EvalMode 24 | import Grisette.Internal.Internal.Impl.Unified.EvalMode () 25 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/EvalModeTag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE TypeFamilyDependencies #-} 5 | 6 | -- | 7 | -- Module : Grisette.Internal.Unified.EvalModeTag 8 | -- Copyright : (c) Sirui Lu 2024 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Internal.Unified.EvalModeTag 15 | ( EvalModeTag (..), 16 | IsConMode, 17 | ) 18 | where 19 | 20 | import Language.Haskell.TH.Syntax (Lift) 21 | 22 | -- | Evaluation mode for unified types. 'C' means concrete evaluation, 'S' 23 | -- means symbolic evaluation. 24 | data EvalModeTag = C | S deriving (Lift, Show, Eq) 25 | 26 | -- | Type family to check if a mode is 'C'. 27 | type family IsConMode (mode :: EvalModeTag) = (r :: Bool) | r -> mode where 28 | IsConMode 'C = 'True 29 | IsConMode 'S = 'False 30 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/FPFPConversion.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.FPFPConversion 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.FPFPConversion 12 | ( UnifiedFPFPConversion, 13 | AllUnifiedFPFPConversion, 14 | ) 15 | where 16 | 17 | import Grisette.Internal.Internal.Decl.Unified.FPFPConversion 18 | import Grisette.Internal.Internal.Impl.Unified.FPFPConversion () 19 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/Theories.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Internal.Unified.Theories 3 | -- Copyright : (c) Sirui Lu 2024 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Internal.Unified.Theories (TheoryToUnify (..), isUFun) where 10 | 11 | -- | This data type is used to represent the theories that is unified. 12 | -- 13 | -- The 'UFun' constructor is used to represent a specific uninterpreted function 14 | -- type. The type is uncurried. 15 | data TheoryToUnify 16 | = UBool 17 | | UIntN 18 | | UWordN 19 | | UInteger 20 | | UAlgReal 21 | | UFP 22 | | UFun [TheoryToUnify] 23 | deriving (Eq, Show) 24 | 25 | -- | Check if the theory is a uninterpreted function. 26 | isUFun :: TheoryToUnify -> Bool 27 | isUFun (UFun _) = True 28 | isUFun _ = False 29 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/UnifiedAlgReal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeFamilyDependencies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | -- | 11 | -- Module : Grisette.Internal.Unified.UnifiedAlgReal 12 | -- Copyright : (c) Sirui Lu 2024 13 | -- License : BSD-3-Clause (see the LICENSE file) 14 | -- 15 | -- Maintainer : siruilu@cs.washington.edu 16 | -- Stability : Experimental 17 | -- Portability : GHC only 18 | module Grisette.Internal.Unified.UnifiedAlgReal 19 | ( UnifiedAlgReal, 20 | GetAlgReal, 21 | ) 22 | where 23 | 24 | import Control.Exception (ArithException) 25 | import Control.Monad.Error.Class (MonadError) 26 | import Grisette.Internal.Core.Data.Class.SafeFdiv (FdivOr) 27 | import Grisette.Internal.SymPrim.AlgReal (AlgReal) 28 | import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) 29 | import Grisette.Internal.SymPrim.SymPrim (Prim) 30 | import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) 31 | import Grisette.Internal.Unified.Class.UnifiedRep 32 | ( UnifiedConRep (ConType), 33 | UnifiedSymRep (SymType), 34 | ) 35 | import Grisette.Internal.Unified.Class.UnifiedSafeFdiv (UnifiedSafeFdiv) 36 | import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) 37 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 38 | import Grisette.Internal.Unified.UnifiedInteger (GetInteger) 39 | import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim) 40 | 41 | class 42 | ( r ~ GetAlgReal mode, 43 | UnifiedConRep r, 44 | UnifiedSymRep r, 45 | ConType r ~ AlgReal, 46 | SymType r ~ SymAlgReal, 47 | UnifiedBasicPrim mode r, 48 | Prim r, 49 | Num r, 50 | Fractional r, 51 | FdivOr r, 52 | forall m. 53 | (UnifiedBranching mode m, MonadError ArithException m) => 54 | UnifiedSafeFdiv mode ArithException r m, 55 | UnifiedFromIntegral mode (GetInteger mode) r 56 | ) => 57 | UnifiedAlgRealImpl (mode :: EvalModeTag) r 58 | | mode -> r 59 | where 60 | -- | Get a unified algebraic real type. Resolves to 'AlgReal' in 'C' mode, 61 | -- and 'SymAlgReal' in 'S' mode. 62 | -- 63 | -- 'Floating', 'Grisette.LogBaseOr' and 'Grisette.SafeLogBase' for 64 | -- 'SymAlgReal' are not provided as they are not available for 'AlgReal'. 65 | type GetAlgReal mode = real | real -> mode 66 | 67 | instance UnifiedAlgRealImpl 'C AlgReal where 68 | type GetAlgReal 'C = AlgReal 69 | 70 | instance UnifiedAlgRealImpl 'S SymAlgReal where 71 | type GetAlgReal 'S = SymAlgReal 72 | 73 | -- | Evaluation mode with unified 'AlgReal' type. 74 | class 75 | (UnifiedAlgRealImpl mode (GetAlgReal mode)) => 76 | UnifiedAlgReal (mode :: EvalModeTag) 77 | 78 | instance UnifiedAlgReal 'C 79 | 80 | instance UnifiedAlgReal 'S 81 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/UnifiedBV.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.UnifiedBV 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.UnifiedBV 12 | ( UnifiedBV, 13 | UnifiedBVImpl (GetIntN, GetWordN), 14 | AllUnifiedBV, 15 | SafeUnifiedBV, 16 | SafeUnifiedSomeBV, 17 | GetSomeWordN, 18 | GetSomeIntN, 19 | SomeBVPair, 20 | ) 21 | where 22 | 23 | import Grisette.Internal.Internal.Decl.Unified.UnifiedBV 24 | import Grisette.Internal.Internal.Impl.Unified.UnifiedBV () 25 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/UnifiedBool.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.UnifiedBool 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.UnifiedBool (UnifiedBool (..)) where 12 | 13 | import Grisette.Internal.Internal.Decl.Unified.UnifiedBool 14 | import Grisette.Internal.Internal.Impl.Unified.UnifiedBool () 15 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/UnifiedFP.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-import-lists #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Unified.UnifiedFP 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Unified.UnifiedFP 12 | ( UnifiedFPImpl (GetFP, GetFPRoundingMode), 13 | UnifiedFP, 14 | SafeUnifiedFP, 15 | AllUnifiedFP, 16 | ) 17 | where 18 | 19 | import Grisette.Internal.Internal.Decl.Unified.UnifiedFP 20 | import Grisette.Internal.Internal.Impl.Unified.UnifiedFP () 21 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/UnifiedInteger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE QuantifiedConstraints #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TypeFamilyDependencies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE UndecidableSuperClasses #-} 12 | 13 | -- | 14 | -- Module : Grisette.Internal.Unified.UnifiedInteger 15 | -- Copyright : (c) Sirui Lu 2024 16 | -- License : BSD-3-Clause (see the LICENSE file) 17 | -- 18 | -- Maintainer : siruilu@cs.washington.edu 19 | -- Stability : Experimental 20 | -- Portability : GHC only 21 | module Grisette.Internal.Unified.UnifiedInteger 22 | ( GetInteger, 23 | UnifiedInteger, 24 | ) 25 | where 26 | 27 | import Control.Exception (ArithException) 28 | import Control.Monad.Except (MonadError) 29 | import Grisette.Internal.SymPrim.SymInteger (SymInteger) 30 | import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral) 31 | import Grisette.Internal.Unified.Class.UnifiedRep 32 | ( UnifiedConRep (ConType), 33 | UnifiedSymRep (SymType), 34 | ) 35 | import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv) 36 | import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith 37 | ( UnifiedSafeLinearArith, 38 | ) 39 | import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching) 40 | import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S)) 41 | import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim) 42 | 43 | class 44 | ( i ~ GetInteger mode, 45 | UnifiedConRep i, 46 | UnifiedSymRep i, 47 | ConType i ~ Integer, 48 | SymType i ~ SymInteger, 49 | UnifiedBasicPrim mode i, 50 | Num i, 51 | forall m. 52 | (UnifiedBranching mode m, MonadError ArithException m) => 53 | UnifiedSafeDiv mode ArithException i m, 54 | forall m. 55 | (UnifiedBranching mode m, MonadError ArithException m) => 56 | UnifiedSafeLinearArith mode ArithException i m, 57 | UnifiedFromIntegral mode i i 58 | ) => 59 | UnifiedIntegerImpl (mode :: EvalModeTag) i 60 | | mode -> i 61 | where 62 | -- | Get a unified Integer type. Resolves to 'Integer' in 'C' mode, and 63 | -- 'SymInteger' in 'S' mode. 64 | type GetInteger mode = int | int -> mode 65 | 66 | instance UnifiedIntegerImpl 'C Integer where 67 | type GetInteger 'C = Integer 68 | 69 | instance UnifiedIntegerImpl 'S SymInteger where 70 | type GetInteger 'S = SymInteger 71 | 72 | -- | Evaluation mode with unified 'Integer' type. 73 | class 74 | (UnifiedIntegerImpl mode (GetInteger mode)) => 75 | UnifiedInteger (mode :: EvalModeTag) 76 | 77 | instance UnifiedInteger 'C 78 | 79 | instance UnifiedInteger 'S 80 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Unified/UnifiedPrim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | 8 | -- | 9 | -- Module : Grisette.Internal.Unified.UnifiedPrim 10 | -- Copyright : (c) Sirui Lu 2024 11 | -- License : BSD-3-Clause (see the LICENSE file) 12 | -- 13 | -- Maintainer : siruilu@cs.washington.edu 14 | -- Stability : Experimental 15 | -- Portability : GHC only 16 | module Grisette.Internal.Unified.UnifiedPrim 17 | ( UnifiedPrim, 18 | UnifiedBasicPrim, 19 | ) 20 | where 21 | 22 | import Grisette.Internal.SymPrim.SymPrim (Prim) 23 | import Grisette.Internal.Unified.BaseConstraint (ConSymConversion) 24 | import Grisette.Internal.Unified.Class.UnifiedITEOp 25 | ( UnifiedITEOp, 26 | ) 27 | import Grisette.Internal.Unified.Class.UnifiedRep 28 | ( UnifiedConRep (ConType), 29 | UnifiedSymRep (SymType), 30 | ) 31 | import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable 32 | ( UnifiedSimpleMergeable, 33 | ) 34 | import Grisette.Internal.Unified.Class.UnifiedSolvable (UnifiedSolvable) 35 | import Grisette.Internal.Unified.Class.UnifiedSymEq (UnifiedSymEq) 36 | import Grisette.Internal.Unified.Class.UnifiedSymOrd (UnifiedSymOrd) 37 | 38 | -- | A type that is used as a constraint for all the (unified) primitive types 39 | -- in Grisette. 40 | type UnifiedPrim mode a = 41 | ( Prim a, 42 | UnifiedITEOp mode a, 43 | UnifiedSymEq mode a, 44 | UnifiedSymOrd mode a 45 | ) 46 | 47 | -- | A type that is used as a constraint for all the basic (unified) primitive 48 | -- types in Grisette. 49 | -- 50 | -- 'Grisette.Internal.Unified.GetSomeWordN' is not considered as a basic (unified) 51 | -- primitive type. 52 | type UnifiedBasicPrim mode a = 53 | ( UnifiedPrim mode a, 54 | UnifiedSimpleMergeable mode a, 55 | UnifiedConRep a, 56 | UnifiedSymRep a, 57 | UnifiedSolvable mode a (ConType a), 58 | ConSymConversion (ConType a) (SymType a) a 59 | ) 60 | -------------------------------------------------------------------------------- /src/Grisette/Internal/Utils/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | -- | 4 | -- Module : Grisette.Internal.Utils.Derive 5 | -- Copyright : (c) Sirui Lu 2021-2023 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Internal.Utils.Derive (Arity0, Arity1) where 12 | 13 | -- | Type-level tag for generic derivation with arity 0. 14 | data Arity0 15 | 16 | -- | Type-level tag for generic derivation with arity 1. 17 | data Arity1 18 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 3 | 4 | -- | 5 | -- Module : Grisette.Lib.Base 6 | -- Copyright : (c) Sirui Lu 2021-2024 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Lib.Base 13 | ( -- * Symbolic or mrg* variants for the operations in the base package 14 | module Grisette.Lib.Control.Applicative, 15 | module Grisette.Lib.Control.Monad, 16 | module Grisette.Lib.Data.Either, 17 | module Grisette.Lib.Data.Foldable, 18 | module Grisette.Lib.Data.Functor, 19 | module Grisette.Lib.Data.Functor.Sum, 20 | module Grisette.Lib.Data.List, 21 | module Grisette.Lib.Data.Maybe, 22 | module Grisette.Lib.Data.Traversable, 23 | module Grisette.Lib.Data.Tuple, 24 | ) 25 | where 26 | 27 | import Grisette.Lib.Control.Applicative 28 | import Grisette.Lib.Control.Monad 29 | import Grisette.Lib.Data.Either 30 | import Grisette.Lib.Data.Foldable 31 | import Grisette.Lib.Data.Functor 32 | import Grisette.Lib.Data.Functor.Sum 33 | import Grisette.Lib.Data.List 34 | import Grisette.Lib.Data.Maybe 35 | import Grisette.Lib.Data.Traversable 36 | import Grisette.Lib.Data.Tuple 37 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | module Grisette.Lib.Control.Monad 5 | ( mrgReturnWithStrategy, 6 | mrgBindWithStrategy, 7 | mrgReturn, 8 | (.>>=), 9 | mrgFoldM, 10 | (.>>), 11 | mrgMzero, 12 | mrgMplus, 13 | ) 14 | where 15 | 16 | import Control.Monad (MonadPlus) 17 | import Grisette.Internal.Core.Data.Class.Mergeable 18 | ( Mergeable, 19 | MergingStrategy, 20 | ) 21 | import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge) 22 | 23 | mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a 24 | mrgBindWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> MergingStrategy b -> u a -> (a -> u b) -> u b 25 | mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a 26 | (.>>=) :: (MonadTryMerge u, Mergeable a, Mergeable b) => u a -> (a -> u b) -> u b 27 | mrgFoldM :: (MonadTryMerge m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b 28 | (.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b 29 | mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a 30 | mrgMplus :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a 31 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad/State/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | 3 | -- | 4 | -- Module : Grisette.Lib.Control.Monad.State.Class 5 | -- Copyright : (c) Sirui Lu 2023 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Lib.Control.Monad.State.Class 12 | ( -- * mrg* variants for operations in "Control.Monad.State.Class" 13 | mrgGet, 14 | mrgPut, 15 | mrgState, 16 | mrgModify, 17 | mrgModify', 18 | mrgGets, 19 | ) 20 | where 21 | 22 | import Control.Monad.State.Class (MonadState (get, put)) 23 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 24 | import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) 25 | import Grisette.Lib.Control.Monad (mrgReturn) 26 | 27 | -- | 'Control.Monad.State.Class.get' with 'Grisette.Core.MergingStrategy' 28 | -- knowledge propagation. 29 | mrgGet :: (MonadState s m, TryMerge m, Mergeable s) => m s 30 | mrgGet = tryMerge get 31 | {-# INLINE mrgGet #-} 32 | 33 | -- | 'Control.Monad.State.Class.put' with 'Grisette.Core.MergingStrategy' 34 | -- knowledge propagation. 35 | mrgPut :: (MonadState s m, TryMerge m) => s -> m () 36 | mrgPut = tryMerge . put 37 | {-# INLINE mrgPut #-} 38 | 39 | -- | 'Control.Monad.State.Class.state' with 'Grisette.Core.MergingStrategy' 40 | -- knowledge propagation. 41 | mrgState :: 42 | (MonadState s m, TryMerge m, Mergeable s, Mergeable a) => 43 | (s -> (a, s)) -> 44 | m a 45 | mrgState f = tryMerge $ do 46 | s <- mrgGet 47 | let ~(a, s') = f s 48 | mrgPut s' 49 | mrgReturn a 50 | 51 | -- | 'Control.Monad.State.Class.modify' with 'Grisette.Core.MergingStrategy' 52 | -- knowledge propagation. 53 | mrgModify :: (MonadState s m, TryMerge m, Mergeable s) => (s -> s) -> m () 54 | mrgModify f = mrgState (\s -> ((), f s)) 55 | {-# INLINE mrgModify #-} 56 | 57 | -- | 'Control.Monad.State.Class.modify'' with 'Grisette.Core.MergingStrategy' 58 | -- knowledge propagation. 59 | mrgModify' :: (MonadState s m, TryMerge m, Mergeable s) => (s -> s) -> m () 60 | mrgModify' f = do 61 | s' <- mrgGet 62 | mrgPut $! f s' 63 | {-# INLINE mrgModify' #-} 64 | 65 | -- | 'Control.Monad.State.Class.gets' with 'Grisette.Core.MergingStrategy' 66 | -- knowledge propagation. 67 | mrgGets :: 68 | (MonadState s m, TryMerge m, Mergeable s, Mergeable a) => 69 | (s -> a) -> 70 | m a 71 | mrgGets f = do 72 | s <- mrgGet 73 | mrgReturn $ f s 74 | {-# INLINE mrgGets #-} 75 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad/Trans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 5 | 6 | -- | 7 | -- Module : Grisette.Lib.Control.Monad.Trans 8 | -- Copyright : (c) Sirui Lu 2021-2023 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Lib.Control.Monad.Trans 15 | ( module Grisette.Lib.Control.Monad.Trans.Class, 16 | ) 17 | where 18 | 19 | import Grisette.Lib.Control.Monad.Trans.Class 20 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad/Trans/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | 5 | -- | 6 | -- Module : Grisette.Lib.Control.Monad.Trans.Class 7 | -- Copyright : (c) Sirui Lu 2021-2023 8 | -- License : BSD-3-Clause (see the LICENSE file) 9 | -- 10 | -- Maintainer : siruilu@cs.washington.edu 11 | -- Stability : Experimental 12 | -- Portability : GHC only 13 | module Grisette.Lib.Control.Monad.Trans.Class 14 | ( -- * mrg* variants for operations in "Control.Monad.Trans.Class" 15 | mrgLift, 16 | ) 17 | where 18 | 19 | import Control.Monad.Trans (MonadTrans (lift)) 20 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 21 | import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) 22 | 23 | -- | 'lift' with 'Grisette.Core.MergingStrategy' knowledge propagation. 24 | mrgLift :: 25 | forall t m a. 26 | (TryMerge (t m), MonadTrans t, Monad m, Mergeable a) => 27 | m a -> 28 | t m a 29 | mrgLift v = tryMerge $ lift v 30 | {-# INLINE mrgLift #-} 31 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad/Trans/Cont.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | 3 | -- | 4 | -- Module : Grisette.Lib.Control.Monad.Trans.Cont 5 | -- Copyright : (c) Sirui Lu 2021-2023 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Lib.Control.Monad.Trans.Cont 12 | ( -- * mrg* variants for operations in "Control.Monad.Trans.Cont" 13 | mrgRunContT, 14 | mrgEvalContT, 15 | mrgResetT, 16 | ) 17 | where 18 | 19 | import Control.Monad.Cont (ContT (runContT)) 20 | import Control.Monad.Trans.Class (lift) 21 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 22 | import Grisette.Internal.Core.Data.Class.TryMerge 23 | ( TryMerge, 24 | tryMerge, 25 | ) 26 | import Grisette.Lib.Control.Monad (mrgReturn) 27 | 28 | -- | 'Control.Monad.Cont.runContT' with 'Grisette.Core.MergingStrategy' 29 | -- knowledge propagation. 30 | mrgRunContT :: (TryMerge m, Mergeable r) => ContT r m a -> (a -> m r) -> m r 31 | mrgRunContT c = tryMerge . runContT c 32 | {-# INLINE mrgRunContT #-} 33 | 34 | -- | 'Control.Monad.Cont.evalContT' with 'Grisette.Core.MergingStrategy' 35 | -- knowledge propagation. 36 | mrgEvalContT :: (TryMerge m, Mergeable r, Monad m) => ContT r m r -> m r 37 | mrgEvalContT c = runContT c mrgReturn 38 | {-# INLINE mrgEvalContT #-} 39 | 40 | -- | 'Control.Monad.Cont.resetT' with 'Grisette.Core.MergingStrategy' knowledge 41 | -- propagation. 42 | mrgResetT :: 43 | (TryMerge m, Mergeable r, Monad m) => 44 | ContT r m r -> 45 | ContT r' m r 46 | mrgResetT = lift . mrgEvalContT 47 | {-# INLINE mrgResetT #-} 48 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad/Trans/Except.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | 3 | -- | 4 | -- Module : Grisette.Lib.Control.Monad.Trans.Except 5 | -- Copyright : (c) Sirui Lu 2024 6 | -- License : BSD-3-Clause (see the LICENSE file) 7 | -- 8 | -- Maintainer : siruilu@cs.washington.edu 9 | -- Stability : Experimental 10 | -- Portability : GHC only 11 | module Grisette.Lib.Control.Monad.Trans.Except 12 | ( mrgExcept, 13 | mrgRunExceptT, 14 | mrgWithExceptT, 15 | mrgThrowE, 16 | mrgCatchE, 17 | ) 18 | where 19 | 20 | import Control.Monad.Trans.Except 21 | ( ExceptT, 22 | catchE, 23 | except, 24 | runExceptT, 25 | throwE, 26 | withExceptT, 27 | ) 28 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 29 | import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge, tryMerge) 30 | 31 | -- | 'Control.Monad.Trans.Except.except' with 'Grisette.Core.MergingStrategy' 32 | -- knowledge propagation. 33 | mrgExcept :: 34 | (MonadTryMerge m, Mergeable e, Mergeable a) => Either e a -> ExceptT e m a 35 | mrgExcept = tryMerge . except 36 | {-# INLINE mrgExcept #-} 37 | 38 | -- | 'Control.Monad.Trans.Except.runExceptT' with 39 | -- 'Grisette.Core.MergingStrategy' knowledge propagation. 40 | mrgRunExceptT :: 41 | (MonadTryMerge m, Mergeable e, Mergeable a) => ExceptT e m a -> m (Either e a) 42 | mrgRunExceptT = tryMerge . runExceptT 43 | {-# INLINE mrgRunExceptT #-} 44 | 45 | -- | 'Control.Monad.Trans.Except.withExceptT' with 46 | -- 'Grisette.Core.MergingStrategy' knowledge propagation. 47 | mrgWithExceptT :: 48 | (MonadTryMerge m, Mergeable a, Mergeable e, Mergeable e') => 49 | (e -> e') -> 50 | ExceptT e m a -> 51 | ExceptT e' m a 52 | mrgWithExceptT f e = tryMerge $ withExceptT f (tryMerge e) 53 | {-# INLINE mrgWithExceptT #-} 54 | 55 | -- | 'Control.Monad.Trans.Except.throwE' with 'Grisette.Core.MergingStrategy' 56 | -- knowledge propagation. 57 | mrgThrowE :: (MonadTryMerge m, Mergeable e, Mergeable a) => e -> ExceptT e m a 58 | mrgThrowE = tryMerge . throwE 59 | {-# INLINE mrgThrowE #-} 60 | 61 | -- | 'Control.Monad.Trans.Except.catchE' with 'Grisette.Core.MergingStrategy' 62 | -- knowledge propagation. 63 | mrgCatchE :: 64 | (MonadTryMerge m, Mergeable e, Mergeable a) => 65 | ExceptT e m a -> 66 | (e -> ExceptT e m a) -> 67 | ExceptT e m a 68 | mrgCatchE value handler = 69 | tryMerge $ catchE (tryMerge value) (tryMerge . handler) 70 | {-# INLINE mrgCatchE #-} 71 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Control/Monad/Trans/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# OPTIONS_GHC -Wno-missing-import-lists #-} 3 | 4 | -- | 5 | -- Module : Grisette.Lib.Control.Monad.Trans.State 6 | -- Copyright : (c) Sirui Lu 2023 7 | -- License : BSD-3-Clause (see the LICENSE file) 8 | -- 9 | -- Maintainer : siruilu@cs.washington.edu 10 | -- Stability : Experimental 11 | -- Portability : GHC only 12 | module Grisette.Lib.Control.Monad.Trans.State 13 | ( module Grisette.Lib.Control.Monad.Trans.State.Lazy, 14 | ) 15 | where 16 | 17 | import Grisette.Lib.Control.Monad.Trans.State.Lazy 18 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Data/Bool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | -- | 7 | -- Module : Grisette.Lib.Data.Bool 8 | -- Copyright : (c) Sirui Lu 2021-2023 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Lib.Data.Bool (mrgTrue, mrgFalse) where 15 | 16 | import Grisette.Internal.TH.Ctor.SmartConstructor 17 | ( makePrefixedSmartCtor, 18 | ) 19 | 20 | makePrefixedSmartCtor "mrg" ''Bool 21 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Data/Either.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | -- | 7 | -- Module : Grisette.Lib.Data.Either 8 | -- Copyright : (c) Sirui Lu 2021-2023 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Lib.Data.Either (mrgLeft, mrgRight) where 15 | 16 | import Grisette.Internal.TH.Ctor.SmartConstructor 17 | ( makePrefixedSmartCtor, 18 | ) 19 | 20 | makePrefixedSmartCtor "mrg" ''Either 21 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Data/Functor.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Lib.Control.Functor 3 | -- Copyright : (c) Sirui Lu 2021-2024 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Lib.Data.Functor 10 | ( mrgFmap, 11 | (.<$), 12 | (.$>), 13 | (.<$>), 14 | (.<&>), 15 | mrgUnzip, 16 | mrgVoid, 17 | ) 18 | where 19 | 20 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 21 | import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) 22 | import qualified Grisette.Unified.Lib.Data.Functor as Unified 23 | 24 | -- | 'fmap' with 'Grisette.Core.MergingStrategy' knowledge propagation. 25 | mrgFmap :: 26 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => 27 | (a -> b) -> 28 | f a -> 29 | f b 30 | mrgFmap = Unified.mrgFmap 31 | {-# INLINE mrgFmap #-} 32 | 33 | infixl 4 .<$> 34 | 35 | -- | '<$>' with 'Grisette.Core.MergingStrategy' knowledge propagation. 36 | (.<$>) :: 37 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b 38 | (.<$>) = (Unified..<$>) 39 | {-# INLINE (.<$>) #-} 40 | 41 | infixl 4 .<$ 42 | 43 | -- | '<$' with 'Grisette.Core.MergingStrategy' knowledge propagation. 44 | (.<$) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => b -> f a -> f b 45 | (.<$) = (Unified..<$) 46 | {-# INLINE (.<$) #-} 47 | 48 | infixl 4 .$> 49 | 50 | -- | 'Data.Functor.$>' with 'Grisette.Core.MergingStrategy' knowledge 51 | -- propagation. 52 | (.$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> b -> f b 53 | (.$>) = (Unified..$>) 54 | {-# INLINE (.$>) #-} 55 | 56 | infixl 1 .<&> 57 | 58 | -- | 'Data.Functor.<&>' with 'Grisette.Core.MergingStrategy' knowledge 59 | -- propagation. 60 | (.<&>) :: 61 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => 62 | f a -> 63 | (a -> b) -> 64 | f b 65 | (.<&>) = (Unified..<&>) 66 | {-# INLINE (.<&>) #-} 67 | 68 | -- | 'unzip' with 'Grisette.Core.MergingStrategy' knowledge propagation. 69 | mrgUnzip :: 70 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => 71 | f (a, b) -> 72 | (f a, f b) 73 | mrgUnzip = Unified.mrgUnzip 74 | {-# INLINE mrgUnzip #-} 75 | 76 | -- | 'Data.Functor.void' with 'Grisette.Core.MergingStrategy' knowledge 77 | -- propagation. 78 | mrgVoid :: (TryMerge f, Functor f) => f a -> f () 79 | mrgVoid = Unified.mrgVoid 80 | {-# INLINE mrgVoid #-} 81 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Data/Functor/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MonoLocalBinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | -- | 7 | -- Module : Grisette.Lib.Data.Functor.Sum 8 | -- Copyright : (c) Sirui Lu 2021-2023 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Lib.Data.Functor.Sum (mrgInR, mrgInL) where 15 | 16 | import Data.Functor.Sum (Sum) 17 | import Grisette.Internal.TH.Ctor.SmartConstructor 18 | ( makePrefixedSmartCtor, 19 | ) 20 | 21 | makePrefixedSmartCtor "mrg" ''Sum 22 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Data/Maybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | -- | 7 | -- Module : Grisette.Lib.Data.Maybe 8 | -- Copyright : (c) Sirui Lu 2021-2023 9 | -- License : BSD-3-Clause (see the LICENSE file) 10 | -- 11 | -- Maintainer : siruilu@cs.washington.edu 12 | -- Stability : Experimental 13 | -- Portability : GHC only 14 | module Grisette.Lib.Data.Maybe (mrgNothing, mrgJust) where 15 | 16 | import Grisette.Internal.TH.Ctor.SmartConstructor 17 | ( makePrefixedSmartCtor, 18 | ) 19 | 20 | makePrefixedSmartCtor "mrg" ''Maybe 21 | -------------------------------------------------------------------------------- /src/Grisette/Lib/Data/Tuple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | -- | 8 | -- Module : Grisette.Lib.Data.Tuple 9 | -- Copyright : (c) Sirui Lu 2021-2023 10 | -- License : BSD-3-Clause (see the LICENSE file) 11 | -- 12 | -- Maintainer : siruilu@cs.washington.edu 13 | -- Stability : Experimental 14 | -- Portability : GHC only 15 | module Grisette.Lib.Data.Tuple 16 | ( mrgUnit, 17 | mrgTuple2, 18 | mrgTuple3, 19 | mrgTuple4, 20 | mrgTuple5, 21 | mrgTuple6, 22 | mrgTuple7, 23 | mrgTuple8, 24 | ) 25 | where 26 | 27 | import Grisette.Internal.TH.Ctor.SmartConstructor 28 | ( makeNamedSmartCtor, 29 | ) 30 | 31 | makeNamedSmartCtor ["mrgUnit"] ''() 32 | makeNamedSmartCtor ["mrgTuple2"] ''(,) 33 | makeNamedSmartCtor ["mrgTuple3"] ''(,,) 34 | makeNamedSmartCtor ["mrgTuple4"] ''(,,,) 35 | makeNamedSmartCtor ["mrgTuple5"] ''(,,,,) 36 | makeNamedSmartCtor ["mrgTuple6"] ''(,,,,,) 37 | makeNamedSmartCtor ["mrgTuple7"] ''(,,,,,,) 38 | makeNamedSmartCtor ["mrgTuple8"] ''(,,,,,,,) 39 | -------------------------------------------------------------------------------- /src/Grisette/Unified/Lib/Control/Monad.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | module Grisette.Unified.Lib.Control.Monad 5 | ( mrgReturnWithStrategy, 6 | mrgBindWithStrategy, 7 | mrgReturn, 8 | (.>>=), 9 | mrgFoldM, 10 | (.>>), 11 | mrgMzero, 12 | mrgMplus, 13 | ) 14 | where 15 | 16 | import Control.Monad (MonadPlus) 17 | import Grisette.Internal.Core.Data.Class.Mergeable 18 | ( Mergeable, 19 | MergingStrategy, 20 | ) 21 | import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge) 22 | 23 | mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a 24 | mrgBindWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> MergingStrategy b -> u a -> (a -> u b) -> u b 25 | mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a 26 | (.>>=) :: (MonadTryMerge u, Mergeable a, Mergeable b) => u a -> (a -> u b) -> u b 27 | mrgFoldM :: (MonadTryMerge m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b 28 | (.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b 29 | mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a 30 | mrgMplus :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a 31 | -------------------------------------------------------------------------------- /src/Grisette/Unified/Lib/Data/Functor.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Grisette.Unified.Lib.Control.Functor 3 | -- Copyright : (c) Sirui Lu 2021-2024 4 | -- License : BSD-3-Clause (see the LICENSE file) 5 | -- 6 | -- Maintainer : siruilu@cs.washington.edu 7 | -- Stability : Experimental 8 | -- Portability : GHC only 9 | module Grisette.Unified.Lib.Data.Functor 10 | ( mrgFmap, 11 | (.<$), 12 | (.$>), 13 | (.<$>), 14 | (.<&>), 15 | mrgUnzip, 16 | mrgVoid, 17 | ) 18 | where 19 | 20 | import Control.Monad (void) 21 | import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) 22 | import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) 23 | 24 | -- | 'fmap' with 'Grisette.Core.MergingStrategy' knowledge propagation. 25 | mrgFmap :: 26 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => 27 | (a -> b) -> 28 | f a -> 29 | f b 30 | mrgFmap f a = tryMerge $ fmap f (tryMerge a) 31 | {-# INLINE mrgFmap #-} 32 | 33 | infixl 4 .<$> 34 | 35 | -- | '<$>' with 'Grisette.Core.MergingStrategy' knowledge propagation. 36 | (.<$>) :: 37 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b 38 | (.<$>) = mrgFmap 39 | {-# INLINE (.<$>) #-} 40 | 41 | infixl 4 .<$ 42 | 43 | -- | '<$' with 'Grisette.Core.MergingStrategy' knowledge propagation. 44 | (.<$) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => b -> f a -> f b 45 | (.<$) v f = tryMerge $ v <$ tryMerge f 46 | {-# INLINE (.<$) #-} 47 | 48 | infixl 4 .$> 49 | 50 | -- | 'Data.Functor.$>' with 'Grisette.Core.MergingStrategy' knowledge 51 | -- propagation. 52 | (.$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> b -> f b 53 | (.$>) = flip (.<$) 54 | {-# INLINE (.$>) #-} 55 | 56 | infixl 1 .<&> 57 | 58 | -- | 'Data.Functor.<&>' with 'Grisette.Core.MergingStrategy' knowledge 59 | -- propagation. 60 | (.<&>) :: 61 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => 62 | f a -> 63 | (a -> b) -> 64 | f b 65 | (.<&>) = flip mrgFmap 66 | {-# INLINE (.<&>) #-} 67 | 68 | -- | 'unzip' with 'Grisette.Core.MergingStrategy' knowledge propagation. 69 | mrgUnzip :: 70 | (TryMerge f, Mergeable a, Mergeable b, Functor f) => 71 | f (a, b) -> 72 | (f a, f b) 73 | mrgUnzip ab = 74 | let mergedAb = tryMerge ab 75 | in (fst .<$> mergedAb, snd .<$> mergedAb) 76 | {-# INLINE mrgUnzip #-} 77 | 78 | -- | 'void' with 'Grisette.Core.MergingStrategy' knowledge propagation. 79 | mrgVoid :: (TryMerge f, Functor f) => f a -> f () 80 | mrgVoid x = tryMerge $ void x 81 | {-# INLINE mrgVoid #-} 82 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: 20 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml 21 | # User packages to be built. 22 | # Various formats can be used as shown in the example below. 23 | # 24 | # packages: 25 | # - some-directory 26 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 27 | # subdirs: 28 | # - auto-update 29 | # - wai 30 | packages: 31 | - . 32 | - examples 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | extra-deps: 44 | - sbv-8.17 45 | - doctest-0.18.2 46 | - unordered-containers-0.2.17.0 47 | 48 | # Override default flag values for local packages and extra-deps 49 | # flags: {} 50 | 51 | # Extra package databases containing global packages 52 | # extra-package-dbs: [] 53 | 54 | # Control whether we use the GHC we find on the path 55 | # system-ghc: true 56 | # 57 | # Require a specific version of stack, using version ranges 58 | # require-stack-version: -any # Default 59 | # require-stack-version: ">=2.7" 60 | # 61 | # Override the architecture used by stack, especially useful on Windows 62 | # arch: i386 63 | # arch: x86_64 64 | # 65 | # Extra directories used by stack for building 66 | # extra-include-dirs: [/path/to/dir] 67 | # extra-lib-dirs: [/path/to/dir] 68 | # 69 | # Allow a newer minor version of GHC than the snapshot specifies 70 | # compiler-check: newer-minor 71 | -------------------------------------------------------------------------------- /stack-8.10.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: sbv-8.17@sha256:3e36afa44ee597b213843495e666d88e604e429f0fcec1bbca05ae847bb752a2,29096 9 | pantry-tree: 10 | sha256: 569fce0cd577b91104a56bab058140978a3c35ab723a602d1b5370c151c95d9f 11 | size: 64220 12 | original: 13 | hackage: sbv-8.17 14 | - completed: 15 | hackage: doctest-0.18.2@sha256:489a6e8d3d687845798a73f7b53b43ebec1a8368d7cd6a959a91080ed253bcd7,7241 16 | pantry-tree: 17 | sha256: cacfd1af86ef3ec7531c528a2771451a47d218a0eca05db00141d29644aef80f 18 | size: 7975 19 | original: 20 | hackage: doctest-0.18.2 21 | - completed: 22 | hackage: unordered-containers-0.2.17.0@sha256:50d72c7945df6389d0bb683dea1c7529b28b26f8c632de186437d1e866af8cf8,3302 23 | pantry-tree: 24 | sha256: b556ac42b7294152a7a6854689310ba70ad7fb1462f5cb0051a188b83433f45c 25 | size: 1517 26 | original: 27 | hackage: unordered-containers-0.2.17.0 28 | snapshots: 29 | - completed: 30 | sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 31 | size: 590100 32 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml 33 | original: 34 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml 35 | -------------------------------------------------------------------------------- /stack-9.0.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: 20 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml 21 | # User packages to be built. 22 | # Various formats can be used as shown in the example below. 23 | # 24 | # packages: 25 | # - some-directory 26 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 27 | # subdirs: 28 | # - auto-update 29 | # - wai 30 | packages: 31 | - . 32 | - examples 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.7" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /stack-9.0.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 6d1532d40621957a25bad5195bfca7938e8a06d923c91bc52aa0f3c41181f2d4 10 | size: 619204 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml 12 | original: 13 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml 14 | -------------------------------------------------------------------------------- /stack-9.10.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: nightly-2025-04-12 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # subdirs: 27 | # - auto-update 28 | # - wai 29 | packages: 30 | - . 31 | - examples 32 | # Dependency packages to be pulled from upstream that are not in the resolver. 33 | # These entries can reference officially published versions as well as 34 | # forks / in-progress versions pinned to a git hash. For example: 35 | # 36 | # extra-deps: 37 | # - acme-missiles-0.3 38 | # - git: https://github.com/commercialhaskell/stack.git 39 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 40 | # 41 | # Override default flag values for local packages and extra-deps 42 | # flags: {} 43 | 44 | # Extra package databases containing global packages 45 | # extra-package-dbs: [] 46 | 47 | # Control whether we use the GHC we find on the path 48 | # system-ghc: true 49 | # 50 | # Require a specific version of stack, using version ranges 51 | # require-stack-version: -any # Default 52 | # require-stack-version: ">=2.7" 53 | # 54 | # Override the architecture used by stack, especially useful on Windows 55 | # arch: i386 56 | # arch: x86_64 57 | # 58 | # Extra directories used by stack for building 59 | # extra-include-dirs: [/path/to/dir] 60 | # extra-lib-dirs: [/path/to/dir] 61 | # 62 | # Allow a newer minor version of GHC than the snapshot specifies 63 | # compiler-check: newer-minor 64 | allow-newer: true 65 | -------------------------------------------------------------------------------- /stack-9.10.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 5c7ae8619fe0a6b36ab11931ec13248f9731722d32da7f1baae982277e086d05 10 | size: 681591 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/4/12.yaml 12 | original: nightly-2025-04-12 13 | -------------------------------------------------------------------------------- /stack-9.2.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: lts-20.26 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # subdirs: 27 | # - auto-update 28 | # - wai 29 | packages: 30 | - . 31 | - examples 32 | # Dependency packages to be pulled from upstream that are not in the resolver. 33 | # These entries can reference officially published versions as well as 34 | # forks / in-progress versions pinned to a git hash. For example: 35 | # 36 | # extra-deps: 37 | # - acme-missiles-0.3 38 | # - git: https://github.com/commercialhaskell/stack.git 39 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 40 | # 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=2.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | -------------------------------------------------------------------------------- /stack-9.2.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 10 | size: 650475 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml 12 | original: lts-20.26 13 | -------------------------------------------------------------------------------- /stack-9.4.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: lts-21.25 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # subdirs: 27 | # - auto-update 28 | # - wai 29 | packages: 30 | - . 31 | - examples 32 | # Dependency packages to be pulled from upstream that are not in the resolver. 33 | # These entries can reference officially published versions as well as 34 | # forks / in-progress versions pinned to a git hash. For example: 35 | # 36 | # extra-deps: 37 | # - acme-missiles-0.3 38 | # - git: https://github.com/commercialhaskell/stack.git 39 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 40 | # 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=2.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | -------------------------------------------------------------------------------- /stack-9.4.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd 10 | size: 640086 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml 12 | original: lts-21.25 13 | -------------------------------------------------------------------------------- /stack-9.6.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: lts-22.43 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # subdirs: 27 | # - auto-update 28 | # - wai 29 | packages: 30 | - . 31 | - examples 32 | # Dependency packages to be pulled from upstream that are not in the resolver. 33 | # These entries can reference officially published versions as well as 34 | # forks / in-progress versions pinned to a git hash. For example: 35 | # 36 | # extra-deps: 37 | # - acme-missiles-0.3 38 | # - git: https://github.com/commercialhaskell/stack.git 39 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 40 | # 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=2.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | -------------------------------------------------------------------------------- /stack-9.6.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146 10 | size: 720271 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml 12 | original: lts-22.43 13 | -------------------------------------------------------------------------------- /stack-9.8.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 7 | # A snapshot resolver dictates the compiler version and the set of packages 8 | # to be used for project dependencies. For example: 9 | # 10 | # resolver: lts-3.5 11 | # resolver: nightly-2015-09-21 12 | # resolver: ghc-7.10.2 13 | # 14 | # The location of a snapshot can be provided as a file or url. Stack assumes 15 | # a snapshot provided as a file might change, whereas a url resource does not. 16 | # 17 | # resolver: ./custom-snapshot.yaml 18 | # resolver: https://example.com/snapshots/2018-01-01.yaml 19 | resolver: lts-23.18 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # subdirs: 27 | # - auto-update 28 | # - wai 29 | packages: 30 | - . 31 | - examples 32 | # Dependency packages to be pulled from upstream that are not in the resolver. 33 | # These entries can reference officially published versions as well as 34 | # forks / in-progress versions pinned to a git hash. For example: 35 | # 36 | # extra-deps: 37 | # - acme-missiles-0.3 38 | # - git: https://github.com/commercialhaskell/stack.git 39 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 40 | # 41 | # extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=2.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | -------------------------------------------------------------------------------- /stack-9.8.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: d133abe75e408a407cce3f032c96ac1bbadf474a93b5156ebf4135b53382d56b 10 | size: 683827 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/18.yaml 12 | original: lts-23.18 13 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-9.10.yaml -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 5c7ae8619fe0a6b36ab11931ec13248f9731722d32da7f1baae982277e086d05 10 | size: 681591 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/4/12.yaml 12 | original: nightly-2025-04-12 13 | -------------------------------------------------------------------------------- /test/Grisette/Core/Data/Class/BitCastTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | module Grisette.Core.Data.Class.BitCastTests (bitCastTests) where 9 | 10 | import Data.Typeable (Proxy (Proxy), Typeable, typeRep) 11 | import Grisette 12 | ( AsKey, 13 | BitCast (bitCast), 14 | FP32, 15 | IntN, 16 | IntN32, 17 | LogicalOp (false, true), 18 | SymBool, 19 | SymFP32, 20 | SymIntN, 21 | SymIntN32, 22 | SymWordN, 23 | SymWordN32, 24 | WordN, 25 | WordN32, 26 | bitCastOrCanonical, 27 | fpNaN, 28 | ) 29 | import Test.Framework (Test, testGroup) 30 | import Test.Framework.Providers.HUnit (testCase) 31 | import Test.HUnit ((@?=)) 32 | 33 | bitCastBit1Tests :: 34 | forall b r. 35 | ( BitCast b r, 36 | BitCast r b, 37 | LogicalOp b, 38 | Num r, 39 | Typeable b, 40 | Typeable r, 41 | Eq b, 42 | Eq r, 43 | Show b, 44 | Show r 45 | ) => 46 | [Test] 47 | bitCastBit1Tests = 48 | [ testCase (bname <> " to " <> rname) $ do 49 | bitCast (true :: b) @?= (1 :: r) 50 | bitCast (false :: b) @?= (0 :: r), 51 | testCase (rname <> " to " <> bname) $ do 52 | bitCast (1 :: r) @?= (true :: b) 53 | bitCast (0 :: r) @?= (false :: b) 54 | ] 55 | where 56 | bname = show $ typeRep (Proxy :: Proxy b) 57 | rname = show $ typeRep (Proxy :: Proxy r) 58 | 59 | bitCastTests :: Test 60 | bitCastTests = 61 | testGroup 62 | "BitCast" 63 | [ testGroup "1 bit" $ 64 | concat 65 | [ bitCastBit1Tests @Bool @(IntN 1), 66 | bitCastBit1Tests @Bool @(WordN 1), 67 | bitCastBit1Tests @(AsKey SymBool) @(AsKey (SymIntN 1)), 68 | bitCastBit1Tests @(AsKey SymBool) @(AsKey (SymWordN 1)) 69 | ], 70 | testGroup 71 | "FP" 72 | [ testCase "FP32" $ do 73 | bitCastOrCanonical (-512.625 :: FP32) @?= (0xc4002800 :: WordN32) 74 | bitCastOrCanonical (fpNaN :: FP32) @?= (0x7fc00000 :: WordN32) 75 | bitCast (0xc4002800 :: WordN32) @?= (-512.625 :: FP32) 76 | bitCastOrCanonical (-512.625 :: FP32) @?= (0xc4002800 :: IntN32) 77 | bitCastOrCanonical (fpNaN :: FP32) @?= (0x7fc00000 :: IntN32) 78 | bitCast (0xc4002800 :: IntN32) @?= (-512.625 :: FP32), 79 | testCase "SymFP32" $ do 80 | bitCastOrCanonical (-512.625 :: SymFP32) 81 | @?= (0xc4002800 :: AsKey SymWordN32) 82 | bitCastOrCanonical (fpNaN :: SymFP32) @?= (0x7fc00000 :: AsKey SymWordN32) 83 | bitCast (0xc4002800 :: SymWordN32) @?= (-512.625 :: AsKey SymFP32) 84 | bitCastOrCanonical (-512.625 :: SymFP32) 85 | @?= (0xc4002800 :: AsKey SymIntN32) 86 | bitCastOrCanonical (fpNaN :: SymFP32) @?= (0x7fc00000 :: AsKey SymIntN32) 87 | bitCast (0xc4002800 :: SymIntN32) @?= (-512.625 :: AsKey SymFP32) 88 | ], 89 | testCase "Nested" $ do 90 | let int32 = "x" :: AsKey SymIntN32 91 | let word32 = bitCast int32 :: AsKey SymWordN32 92 | let final = bitCast word32 :: AsKey SymIntN32 93 | final @?= int32 94 | ] 95 | -------------------------------------------------------------------------------- /test/Grisette/Core/Data/Class/BoolTests.hs: -------------------------------------------------------------------------------- 1 | module Grisette.Core.Data.Class.BoolTests (boolTests) where 2 | 3 | import Grisette 4 | ( LogicalOp (false, symImplies, symNot, symXor, true, (.&&), (.||)), 5 | ) 6 | import Test.Framework (Test, testGroup) 7 | import Test.Framework.Providers.HUnit (testCase) 8 | import Test.HUnit ((@?=)) 9 | 10 | data CustomAndBool 11 | = CACBool Bool 12 | | CASBool String 13 | | CAAnd CustomAndBool CustomAndBool 14 | | CANot CustomAndBool 15 | deriving (Show, Eq) 16 | 17 | instance LogicalOp CustomAndBool where 18 | true = CACBool True 19 | symNot (CACBool b) = CACBool $ not b 20 | symNot (CANot x) = x 21 | symNot x = CANot x 22 | (.&&) = CAAnd 23 | 24 | data CustomOrBool 25 | = COCBool Bool 26 | | COSBool String 27 | | COOr CustomOrBool CustomOrBool 28 | | CONot CustomOrBool 29 | deriving (Show, Eq) 30 | 31 | instance LogicalOp CustomOrBool where 32 | false = COCBool False 33 | symNot (COCBool b) = COCBool $ not b 34 | symNot (CONot x) = x 35 | symNot x = CONot x 36 | (.||) = COOr 37 | 38 | boolTests :: Test 39 | boolTests = 40 | testGroup 41 | "Bool" 42 | [ testGroup 43 | "LogicalOp" 44 | [ testGroup 45 | "Use and" 46 | [ testCase "symNot" $ 47 | symNot (CASBool "a") @?= CANot (CASBool "a"), 48 | testCase ".&&" $ 49 | CASBool "a" 50 | .&& CASBool "b" 51 | @?= CAAnd (CASBool "a") (CASBool "b"), 52 | testCase ".||" $ 53 | CASBool "a" 54 | .|| CASBool "b" 55 | @?= CANot (CAAnd (CANot $ CASBool "a") (CANot $ CASBool "b")) 56 | ], 57 | testGroup 58 | "Use or" 59 | [ testCase "symNot" $ 60 | symNot (COSBool "a") @?= CONot (COSBool "a"), 61 | testCase ".&&" $ 62 | COSBool "a" 63 | .&& COSBool "b" 64 | @?= CONot (COOr (CONot $ COSBool "a") (CONot $ COSBool "b")), 65 | testCase ".||" $ 66 | COSBool "a" 67 | .|| COSBool "b" 68 | @?= COOr (COSBool "a") (COSBool "b"), 69 | testCase "symXor" $ 70 | COSBool "a" 71 | `symXor` COSBool "b" 72 | @?= COOr 73 | (CONot (COOr (CONot (COSBool "a")) (COSBool "b"))) 74 | (CONot (COOr (COSBool "a") (CONot (COSBool "b")))), 75 | testCase "symImplies" $ 76 | COSBool "a" 77 | `symImplies` COSBool "b" 78 | @?= COOr 79 | (CONot (COSBool "a")) 80 | (COSBool "b") 81 | ] 82 | ] 83 | ] 84 | -------------------------------------------------------------------------------- /test/Grisette/Core/Data/Class/TestValues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Grisette.Core.Data.Class.TestValues 4 | ( conBool, 5 | symTrue, 6 | symFalse, 7 | ssymBool, 8 | isymBool, 9 | ssymbolBool, 10 | isymbolBool, 11 | ) 12 | where 13 | 14 | import Grisette 15 | ( Identifier, 16 | Solvable (con, isym, ssym), 17 | SymBool, 18 | Symbol (IndexedSymbol, SimpleSymbol), 19 | TypedAnySymbol, 20 | typedAnySymbol, 21 | ) 22 | 23 | conBool :: Bool -> SymBool 24 | conBool = con 25 | 26 | symTrue :: SymBool 27 | symTrue = conBool True 28 | 29 | symFalse :: SymBool 30 | symFalse = conBool False 31 | 32 | ssymBool :: Identifier -> SymBool 33 | ssymBool = ssym 34 | 35 | isymBool :: Identifier -> Int -> SymBool 36 | isymBool = isym 37 | 38 | ssymbolBool :: Identifier -> TypedAnySymbol Bool 39 | ssymbolBool = typedAnySymbol . SimpleSymbol 40 | 41 | isymbolBool :: Identifier -> Int -> TypedAnySymbol Bool 42 | isymbolBool i idx = typedAnySymbol $ IndexedSymbol i idx 43 | -------------------------------------------------------------------------------- /test/Grisette/Core/TH/PartialEvalMode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE MonoLocalBinds #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Grisette.Core.TH.PartialEvalMode 8 | ( PartialEvalMode, 9 | MonadPartialEvalMode, 10 | ) 11 | where 12 | 13 | import Grisette.Unified 14 | ( TheoryToUnify (UBool, UFP, UWordN), 15 | genEvalMode, 16 | ) 17 | 18 | genEvalMode "PartialEvalMode" [UBool, UWordN, UFP] 19 | -------------------------------------------------------------------------------- /test/Grisette/Lib/Control/Monad/State/ClassTests.hs: -------------------------------------------------------------------------------- 1 | module Grisette.Lib.Control.Monad.State.ClassTests 2 | ( monadStateClassTests, 3 | ) 4 | where 5 | 6 | import Control.Monad.Trans.State.Lazy (StateT (StateT), runStateT) 7 | import Grisette.Lib.Control.Monad.State.Class 8 | ( mrgGet, 9 | mrgGets, 10 | mrgModify, 11 | mrgModify', 12 | mrgPut, 13 | mrgState, 14 | ) 15 | import Grisette.Lib.Control.Monad.Trans.State.Common 16 | ( mrgGetTest, 17 | mrgGetsTest, 18 | mrgModifyTest, 19 | mrgPutTest, 20 | mrgStateTest, 21 | ) 22 | import Test.Framework (Test, testGroup) 23 | import Test.Framework.Providers.HUnit (testCase) 24 | 25 | monadStateClassTests :: Test 26 | monadStateClassTests = 27 | testGroup 28 | "Class" 29 | [ testCase "mrgState" $ mrgStateTest mrgState runStateT, 30 | testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet, 31 | testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut, 32 | testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify, 33 | testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify', 34 | testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets 35 | ] 36 | -------------------------------------------------------------------------------- /test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Grisette.Lib.Control.Monad.Trans.ClassTests 4 | ( monadTransClassTests, 5 | ) 6 | where 7 | 8 | import Control.Monad.Except (ExceptT) 9 | import Grisette 10 | ( AsKey, 11 | AsKey1, 12 | ITEOp (symIte), 13 | SymBranching (mrgIfPropagatedStrategy), 14 | Union, 15 | mrgSingle, 16 | ) 17 | import Grisette.Lib.Control.Monad.Trans (mrgLift) 18 | import Grisette.SymPrim (SymBool) 19 | import Test.Framework (Test, testGroup) 20 | import Test.Framework.Providers.HUnit (testCase) 21 | import Test.HUnit ((@?=)) 22 | 23 | monadTransClassTests :: Test 24 | monadTransClassTests = 25 | testGroup 26 | "Class" 27 | [ testCase "mrgLift" $ do 28 | ( mrgLift 29 | ( mrgIfPropagatedStrategy "a" (return "b") (return "c") :: 30 | AsKey1 Union (AsKey SymBool) 31 | ) :: 32 | ExceptT (AsKey SymBool) (AsKey1 Union) (AsKey SymBool) 33 | ) 34 | @?= mrgSingle (symIte "a" "b" "c") 35 | ] 36 | -------------------------------------------------------------------------------- /test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Grisette.Lib.Control.Monad.Trans.ExceptTests (exceptTests) where 4 | 5 | import Control.Monad.Except 6 | ( ExceptT (ExceptT), 7 | MonadError (throwError), 8 | runExceptT, 9 | ) 10 | import Grisette 11 | ( ITEOp (symIte), 12 | SymBranching (mrgIfPropagatedStrategy), 13 | Union, 14 | mrgIf, 15 | mrgSingle, 16 | ) 17 | import Grisette.Lib.Control.Monad.Trans.Except 18 | ( mrgCatchE, 19 | mrgExcept, 20 | mrgRunExceptT, 21 | mrgThrowE, 22 | mrgWithExceptT, 23 | ) 24 | import Grisette.SymPrim (SymBool, SymInteger) 25 | import Grisette.TestUtil.SymbolicAssertion ((.@?=)) 26 | import Test.Framework (Test, testGroup) 27 | import Test.Framework.Providers.HUnit (testCase) 28 | 29 | unmergedExceptT :: ExceptT SymInteger Union SymBool 30 | unmergedExceptT = 31 | mrgIfPropagatedStrategy 32 | "e" 33 | (mrgIfPropagatedStrategy "c" (throwError "a") (throwError "b")) 34 | (return "d") 35 | 36 | mergedExceptT :: ExceptT SymInteger Union SymBool 37 | mergedExceptT = 38 | ExceptT $ 39 | mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b"))) (mrgSingle (Right "d")) 40 | 41 | mergedExceptTPlus1 :: ExceptT SymInteger Union SymBool 42 | mergedExceptTPlus1 = 43 | ExceptT $ 44 | mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b" + 1))) (mrgSingle (Right "d")) 45 | 46 | exceptTests :: Test 47 | exceptTests = 48 | testGroup 49 | "Except" 50 | [ testCase "mrgExcept" $ do 51 | let actual = mrgExcept (Left "a") :: ExceptT SymInteger Union SymBool 52 | let expected = ExceptT (mrgSingle (Left "a")) 53 | actual .@?= expected, 54 | testCase "mrgRunExceptT" $ do 55 | mrgRunExceptT unmergedExceptT .@?= runExceptT mergedExceptT, 56 | testCase "mrgWithExceptT" $ do 57 | mrgWithExceptT (+ 1) unmergedExceptT .@?= mergedExceptTPlus1, 58 | testCase "mrgThrowE" $ do 59 | let actual = mrgThrowE "a" :: ExceptT SymInteger Union SymBool 60 | actual .@?= ExceptT (mrgSingle (Left "a")), 61 | testCase "mrgCatchE" $ do 62 | let actual = mrgCatchE unmergedExceptT (throwError . (+ 1)) 63 | actual .@?= mergedExceptTPlus1 64 | ] 65 | -------------------------------------------------------------------------------- /test/Grisette/Lib/Control/Monad/Trans/State/LazyTests.hs: -------------------------------------------------------------------------------- 1 | module Grisette.Lib.Control.Monad.Trans.State.LazyTests 2 | ( monadTransStateLazyTests, 3 | ) 4 | where 5 | 6 | import Control.Monad.Trans.State.Lazy (StateT (StateT), runStateT) 7 | import Grisette.Lib.Control.Monad.Trans.State.Common 8 | ( mrgEvalStateTTest, 9 | mrgExecStateTTest, 10 | mrgGetTest, 11 | mrgGetsTest, 12 | mrgMapStateTTest, 13 | mrgModifyTest, 14 | mrgPutTest, 15 | mrgRunStateTTest, 16 | mrgStateTest, 17 | mrgWithStateTTest, 18 | ) 19 | import Grisette.Lib.Control.Monad.Trans.State.Lazy 20 | ( mrgEvalStateT, 21 | mrgExecStateT, 22 | mrgGet, 23 | mrgGets, 24 | mrgMapStateT, 25 | mrgModify, 26 | mrgModify', 27 | mrgPut, 28 | mrgRunStateT, 29 | mrgState, 30 | mrgWithStateT, 31 | ) 32 | import Test.Framework (Test, testGroup) 33 | import Test.Framework.Providers.HUnit (testCase) 34 | 35 | monadTransStateLazyTests :: Test 36 | monadTransStateLazyTests = 37 | testGroup 38 | "Lazy" 39 | [ testCase "mrgState" $ mrgStateTest mrgState runStateT, 40 | testCase "mrgRunStateT" $ mrgRunStateTTest StateT mrgRunStateT, 41 | testCase "mrgEvalStateT" $ mrgEvalStateTTest StateT mrgEvalStateT, 42 | testCase "mrgExecStateT" $ mrgExecStateTTest StateT mrgExecStateT, 43 | testCase "mrgMapStateT" $ mrgMapStateTTest StateT runStateT mrgMapStateT, 44 | testCase "mrgWithStateT" $ 45 | mrgWithStateTTest StateT runStateT mrgWithStateT, 46 | testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet, 47 | testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut, 48 | testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify, 49 | testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify', 50 | testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets 51 | ] 52 | -------------------------------------------------------------------------------- /test/Grisette/Lib/Control/Monad/Trans/State/StrictTests.hs: -------------------------------------------------------------------------------- 1 | module Grisette.Lib.Control.Monad.Trans.State.StrictTests 2 | ( monadTransStateStrictTests, 3 | ) 4 | where 5 | 6 | import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT) 7 | import Grisette.Lib.Control.Monad.Trans.State.Common 8 | ( mrgEvalStateTTest, 9 | mrgExecStateTTest, 10 | mrgGetTest, 11 | mrgGetsTest, 12 | mrgMapStateTTest, 13 | mrgModifyTest, 14 | mrgPutTest, 15 | mrgRunStateTTest, 16 | mrgStateTest, 17 | mrgWithStateTTest, 18 | ) 19 | import Grisette.Lib.Control.Monad.Trans.State.Strict 20 | ( mrgEvalStateT, 21 | mrgExecStateT, 22 | mrgGet, 23 | mrgGets, 24 | mrgMapStateT, 25 | mrgModify, 26 | mrgModify', 27 | mrgPut, 28 | mrgRunStateT, 29 | mrgState, 30 | mrgWithStateT, 31 | ) 32 | import Test.Framework (Test, testGroup) 33 | import Test.Framework.Providers.HUnit (testCase) 34 | 35 | monadTransStateStrictTests :: Test 36 | monadTransStateStrictTests = 37 | testGroup 38 | "Strict" 39 | [ testCase "mrgState" $ mrgStateTest mrgState runStateT, 40 | testCase "mrgRunStateT" $ mrgRunStateTTest StateT mrgRunStateT, 41 | testCase "mrgEvalStateT" $ mrgEvalStateTTest StateT mrgEvalStateT, 42 | testCase "mrgExecStateT" $ mrgExecStateTTest StateT mrgExecStateT, 43 | testCase "mrgMapStateT" $ mrgMapStateTTest StateT runStateT mrgMapStateT, 44 | testCase "mrgWithStateT" $ 45 | mrgWithStateTTest StateT runStateT mrgWithStateT, 46 | testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet, 47 | testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut, 48 | testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify, 49 | testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify', 50 | testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets 51 | ] 52 | -------------------------------------------------------------------------------- /test/Grisette/SymPrim/Prim/ConcurrentTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -fno-cse #-} 3 | 4 | module Grisette.SymPrim.Prim.ConcurrentTests (concurrentTests) where 5 | 6 | import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) 7 | import Control.DeepSeq (force) 8 | import Control.Exception (evaluate) 9 | import Data.Hashable (Hashable (hash)) 10 | import Data.String (IsString (fromString)) 11 | import Grisette (SymEq ((.==)), SymInteger (SymInteger), evalSymToCon, solve, z3) 12 | import Test.Framework (Test, testGroup) 13 | import Test.Framework.Providers.HUnit (testCase) 14 | import Test.HUnit ((@?=)) 15 | 16 | concurrentTests :: Test 17 | concurrentTests = 18 | testGroup 19 | "Concurrent" 20 | [ testCase "Consistent hash/eq" $ do 21 | aref <- newEmptyMVar 22 | bref <- newEmptyMVar 23 | _ <- forkIO $ do 24 | evaluate $ force (map (fromString . show) [1 .. 1000] :: [SymInteger]) 25 | evaluate $ force ("x" :: SymInteger) 26 | SymInteger p <- evaluate $ force ("y" + "z" :: SymInteger) 27 | putMVar aref p 28 | ar <- takeMVar aref 29 | _ <- forkIO $ do 30 | SymInteger p <- evaluate $ force ("y" + "z" :: SymInteger) 31 | putMVar bref p 32 | br <- takeMVar bref 33 | ar @?= br 34 | hash ar @?= hash br, 35 | testCase "Eval" $ do 36 | aref <- newEmptyMVar 37 | bref <- newEmptyMVar 38 | _ <- forkIO $ do 39 | a <- evaluate $ force ("a" :: SymInteger) 40 | putMVar aref a 41 | _ <- forkIO $ do 42 | b <- evaluate $ force ("b" :: SymInteger) 43 | putMVar bref b 44 | a <- takeMVar aref 45 | b <- takeMVar bref 46 | r <- solve z3 $ a .== b 47 | case r of 48 | Left err -> error $ show err 49 | Right m -> evalSymToCon m a @?= (evalSymToCon m b :: Integer) 50 | ] 51 | -------------------------------------------------------------------------------- /test/Grisette/SymPrim/Prim/TabularFunTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Grisette.SymPrim.Prim.TabularFunTests (tabularFunTests) where 6 | 7 | import Grisette 8 | ( type (=->) (TabularFun), 9 | ) 10 | import Grisette.Internal.SymPrim.Prim.Term 11 | ( PEvalApplyTerm (pevalApplyTerm), 12 | SupportedPrim (pevalITETerm), 13 | Term, 14 | applyTerm, 15 | conTerm, 16 | pevalEqTerm, 17 | ssymTerm, 18 | ) 19 | import Test.Framework (Test, testGroup) 20 | import Test.Framework.Providers.HUnit (testCase) 21 | import Test.HUnit ((@?=)) 22 | 23 | tabularFunTests :: Test 24 | tabularFunTests = 25 | testGroup 26 | "TabularFun" 27 | [ testGroup 28 | "Apply" 29 | [ testCase "On concrete" $ do 30 | let f :: Integer =-> Integer = 31 | TabularFun [(1, 2), (3, 4)] 5 32 | pevalApplyTerm (conTerm f) (conTerm 0) @?= conTerm 5 33 | pevalApplyTerm (conTerm f) (conTerm 1) @?= conTerm 2 34 | pevalApplyTerm (conTerm f) (conTerm 2) @?= conTerm 5 35 | pevalApplyTerm (conTerm f) (conTerm 3) @?= conTerm 4 36 | pevalApplyTerm (conTerm f) (conTerm 4) @?= conTerm 5, 37 | testCase "On concrete function" $ do 38 | let f :: Integer =-> Integer = 39 | TabularFun [(1, 2), (3, 4)] 5 40 | pevalApplyTerm (conTerm f) (ssymTerm "b") 41 | @?= pevalITETerm 42 | (pevalEqTerm (conTerm 1 :: Term Integer) (ssymTerm "b")) 43 | (conTerm 2) 44 | ( pevalITETerm 45 | (pevalEqTerm (conTerm 3 :: Term Integer) (ssymTerm "b")) 46 | (conTerm 4) 47 | (conTerm 5) 48 | ), 49 | testCase "On symbolic" $ do 50 | pevalApplyTerm 51 | (ssymTerm "f" :: Term (Integer =-> Integer)) 52 | (ssymTerm "a") 53 | @?= applyTerm 54 | (ssymTerm "f" :: Term (Integer =-> Integer)) 55 | (ssymTerm "a" :: Term Integer) 56 | ] 57 | ] 58 | -------------------------------------------------------------------------------- /test/Grisette/SymPrim/QuantifierTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Grisette.SymPrim.QuantifierTests (quantifierTests) where 7 | 8 | import Grisette 9 | ( AsKey (AsKey), 10 | Function ((#)), 11 | GenSymSimple (simpleFresh), 12 | LogicalOp (symImplies), 13 | ModelOps (isEmptyModel), 14 | SimpleListSpec (SimpleListSpec), 15 | SymEq ((.==)), 16 | SymOrd ((.>)), 17 | runFresh, 18 | solve, 19 | z3, 20 | ) 21 | import Grisette.Internal.SymPrim.Quantifier (existsFresh, existsSym, forallFresh, forallSym) 22 | import Grisette.Internal.SymPrim.SymInteger (SymInteger) 23 | import Grisette.SymPrim (type (=~>)) 24 | import Test.Framework (Test, testGroup) 25 | import Test.Framework.Providers.HUnit (testCase) 26 | import Test.HUnit (assertBool, (@?=)) 27 | 28 | #if MIN_VERSION_sbv(10,1,0) 29 | sbvVersionCheck :: Test -> Test 30 | sbvVersionCheck = id 31 | #else 32 | sbvVersionCheck :: Test -> Test 33 | sbvVersionCheck _ = testGroup "Quantifier" [] 34 | #endif 35 | 36 | quantifierTests :: Test 37 | quantifierTests = 38 | sbvVersionCheck $ 39 | testGroup 40 | "Quantifier" 41 | [ testCase "Basic" $ do 42 | let l@[x, y] = ["x", "y"] :: [SymInteger] 43 | r <- solve z3 $ forallSym l $ (x .== y) `symImplies` (x + 1 .== y + 1) 44 | case r of 45 | Left err -> error $ show err 46 | Right mo -> 47 | assertBool "no elements should be in the model" $ isEmptyModel mo, 48 | testCase "Basic2" $ do 49 | let [x, y] = ["x", "y"] :: [SymInteger] 50 | r <- solve z3 $ forallSym x $ existsSym y $ x .> y 51 | case r of 52 | Left err -> error $ show err 53 | Right mo -> 54 | assertBool "no elements should be in the model" $ isEmptyModel mo, 55 | testCase "With ufunc" $ do 56 | -- https://github.com/LeventErkok/sbv/issues/711 57 | let f = "f" :: SymInteger =~> SymInteger 58 | let x = "x" :: SymInteger 59 | let y = "y" :: SymInteger 60 | r <- 61 | solve z3 $ 62 | forallSym x $ 63 | forallSym y $ 64 | (x .== y) `symImplies` ((f # x) .== (f # y)) 65 | case r of 66 | Left err -> error $ show err 67 | Right _ -> return (), 68 | testCase "fresh" $ do 69 | let x = flip runFresh "x" $ 70 | forallFresh (SimpleListSpec 2 ()) $ \(l :: [SymInteger]) -> 71 | existsFresh (SimpleListSpec 2 ()) $ \(r :: [SymInteger]) -> 72 | return $ l .== r 73 | let r = flip runFresh "x" $ do 74 | l :: [SymInteger] <- simpleFresh (SimpleListSpec 2 ()) 75 | r <- simpleFresh (SimpleListSpec 2 ()) 76 | return $ forallSym l $ existsSym r $ l .== r 77 | AsKey x @?= AsKey r 78 | ] 79 | -------------------------------------------------------------------------------- /test/Grisette/SymPrim/SymGeneralFunTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Grisette.SymPrim.SymGeneralFunTests (symGeneralFunTests) where 6 | 7 | import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym (extractSymMaybe)) 8 | import Grisette.Internal.Core.Data.Class.Function (Function ((#))) 9 | import Grisette.Internal.Core.Data.Class.ModelOps 10 | ( SymbolSetRep (buildSymbolSet), 11 | ) 12 | import Grisette.Internal.SymPrim.GeneralFun (type (-->)) 13 | import Grisette.Internal.SymPrim.Prim.Internal.Term (TypedAnySymbol) 14 | import Grisette.Internal.SymPrim.Prim.Model (AnySymbolSet, ConstantSymbolSet) 15 | import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) 16 | import Grisette.Internal.SymPrim.SymInteger (SymInteger) 17 | import Test.Framework (Test, testGroup) 18 | import Test.Framework.Providers.HUnit (testCase) 19 | import Test.HUnit ((@?=)) 20 | 21 | symGeneralFunTests :: Test 22 | symGeneralFunTests = 23 | testGroup 24 | "SymGeneralFun" 25 | [ testCase "ExtractSym" $ do 26 | let f :: SymInteger -~> SymInteger = "f" 27 | let a :: SymInteger = "a" 28 | let fa = f # a 29 | let anySymbolSet = 30 | buildSymbolSet 31 | ( "a" :: TypedAnySymbol Integer, 32 | "f" :: TypedAnySymbol (Integer --> Integer) 33 | ) :: 34 | AnySymbolSet 35 | extractSymMaybe fa @?= Just anySymbolSet 36 | extractSymMaybe fa @?= (Nothing :: Maybe ConstantSymbolSet) 37 | ] 38 | -------------------------------------------------------------------------------- /test/Grisette/SymPrim/SymPrimConstraintTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module Grisette.SymPrim.SymPrimConstraintTests 5 | ( symBool, 6 | symInteger, 7 | symWordN8, 8 | symIntN8, 9 | symFP32, 10 | symAlgReal, 11 | someSymWordN, 12 | someSymIntN, 13 | bool, 14 | integer, 15 | wordN8, 16 | intN8, 17 | fp32, 18 | algReal, 19 | someWordN, 20 | someIntN, 21 | ) 22 | where 23 | 24 | import Grisette 25 | ( AlgReal, 26 | BasicSymPrim, 27 | FP32, 28 | IntN8, 29 | Prim, 30 | SomeSymWordN, 31 | SymAlgReal, 32 | SymBool, 33 | SymFP32, 34 | SymIntN8, 35 | SymInteger, 36 | SymPrim, 37 | SymWordN8, 38 | WordN8, 39 | ) 40 | import Grisette.Internal.SymPrim.SomeBV (SomeIntN, SomeSymIntN, SomeWordN) 41 | 42 | data BasicSymPrimType a where 43 | BasicSymPrimType :: (BasicSymPrim a) => BasicSymPrimType a 44 | 45 | symBool :: BasicSymPrimType SymBool 46 | symBool = BasicSymPrimType 47 | 48 | symInteger :: BasicSymPrimType SymInteger 49 | symInteger = BasicSymPrimType 50 | 51 | symWordN8 :: BasicSymPrimType SymWordN8 52 | symWordN8 = BasicSymPrimType 53 | 54 | symIntN8 :: BasicSymPrimType SymIntN8 55 | symIntN8 = BasicSymPrimType 56 | 57 | symFP32 :: BasicSymPrimType SymFP32 58 | symFP32 = BasicSymPrimType 59 | 60 | symAlgReal :: BasicSymPrimType SymAlgReal 61 | symAlgReal = BasicSymPrimType 62 | 63 | data SymPrimType a where 64 | SymPrimType :: (SymPrim a) => SymPrimType a 65 | 66 | someSymWordN :: SymPrimType SomeSymWordN 67 | someSymWordN = SymPrimType 68 | 69 | someSymIntN :: SymPrimType SomeSymIntN 70 | someSymIntN = SymPrimType 71 | 72 | data PrimType a where 73 | PrimType :: (Prim a) => PrimType a 74 | 75 | bool :: PrimType Bool 76 | bool = PrimType 77 | 78 | integer :: PrimType Integer 79 | integer = PrimType 80 | 81 | wordN8 :: PrimType WordN8 82 | wordN8 = PrimType 83 | 84 | intN8 :: PrimType IntN8 85 | intN8 = PrimType 86 | 87 | fp32 :: PrimType FP32 88 | fp32 = PrimType 89 | 90 | algReal :: PrimType AlgReal 91 | algReal = PrimType 92 | 93 | someWordN :: PrimType SomeWordN 94 | someWordN = PrimType 95 | 96 | someIntN :: PrimType SomeIntN 97 | someIntN = PrimType 98 | -------------------------------------------------------------------------------- /test/Grisette/SymPrim/TabularFunTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module Grisette.SymPrim.TabularFunTests (tabularFunTests) where 5 | 6 | import Grisette 7 | ( Function ((#)), 8 | type (=->) (TabularFun), 9 | ) 10 | import Test.Framework (Test, testGroup) 11 | import Test.Framework.Providers.HUnit (testCase) 12 | import Test.HUnit ((@?=)) 13 | 14 | tabularFunTests :: Test 15 | tabularFunTests = 16 | testGroup 17 | "TabularFun" 18 | [ testCase "Tabular application" $ do 19 | let f :: Integer =-> Integer = TabularFun [(1, 2), (3, 4)] 5 20 | (f # 0) @?= 5 21 | (f # 1) @?= 2 22 | (f # 2) @?= 5 23 | (f # 3) @?= 4 24 | (f # 4) @?= 5 25 | ] 26 | -------------------------------------------------------------------------------- /test/Grisette/TestUtil/NoMerge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Grisette.TestUtil.NoMerge 5 | ( NoMerge (..), 6 | oneNotMerged, 7 | noMergeNotMerged, 8 | ) 9 | where 10 | 11 | import GHC.Generics (Generic) 12 | import Grisette 13 | ( AsKey1, 14 | Mergeable (rootStrategy), 15 | MergingStrategy (NoStrategy), 16 | SymBranching (mrgIfPropagatedStrategy), 17 | Union, 18 | ) 19 | 20 | data NoMerge = NoMerge 21 | deriving (Show, Eq, Generic) 22 | 23 | instance Mergeable NoMerge where 24 | rootStrategy = NoStrategy 25 | 26 | oneNotMerged :: AsKey1 Union Int 27 | oneNotMerged = mrgIfPropagatedStrategy "a" (return 1) (return 1) 28 | 29 | noMergeNotMerged :: AsKey1 Union NoMerge 30 | noMergeNotMerged = mrgIfPropagatedStrategy "a" (return NoMerge) (return NoMerge) 31 | -------------------------------------------------------------------------------- /test/Grisette/TestUtil/PrettyPrint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Grisette.TestUtil.PrettyPrint (renderedAs, compactRenderedAs) where 4 | 5 | import qualified Data.Text as T 6 | #if MIN_VERSION_prettyprinter(1,7,0) 7 | import Prettyprinter 8 | ( Doc, 9 | LayoutOptions (LayoutOptions), 10 | PageWidth (AvailablePerLine, Unbounded), 11 | layoutSmart, 12 | ) 13 | import Prettyprinter.Render.Text (renderStrict) 14 | #else 15 | import Data.Text.Prettyprint.Doc 16 | ( Doc, 17 | LayoutOptions (LayoutOptions), 18 | PageWidth (AvailablePerLine, Unbounded), 19 | layoutSmart, 20 | ) 21 | import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) 22 | #endif 23 | 24 | renderedAs :: Doc ann -> T.Text -> IO () 25 | renderedAs doc expected = do 26 | let actual = renderStrict $ layoutSmart (LayoutOptions Unbounded) doc 27 | if actual == expected 28 | then return () 29 | else 30 | fail $ 31 | "Expected: " ++ T.unpack expected ++ "\nActual: " ++ T.unpack actual 32 | 33 | compactRenderedAs :: Doc ann -> T.Text -> IO () 34 | compactRenderedAs doc expected = do 35 | let actual = 36 | renderStrict $ layoutSmart (LayoutOptions (AvailablePerLine 1 1)) doc 37 | if actual == expected 38 | then return () 39 | else 40 | fail $ 41 | "Expected: " ++ T.unpack expected ++ "\nActual: " ++ T.unpack actual 42 | -------------------------------------------------------------------------------- /test/Grisette/TestUtil/SymbolicAssertion.hs: -------------------------------------------------------------------------------- 1 | module Grisette.TestUtil.SymbolicAssertion ((@?=~), (.@?=), symShouldEq) where 2 | 3 | import GHC.Stack (HasCallStack) 4 | import Grisette 5 | ( EvalSym (evalSym), 6 | LogicalOp (symNot), 7 | Model, 8 | SolvingFailure (Unsat), 9 | SymEq ((./=), (.==)), 10 | solve, 11 | z3, 12 | ) 13 | import Test.HUnit (Assertion) 14 | 15 | (@?=~) :: (HasCallStack, SymEq a, Show a, EvalSym a) => a -> a -> Assertion 16 | actual @?=~ expected = do 17 | cex <- solve z3 (symNot $ actual .== expected) 18 | case cex of 19 | Left Unsat -> return () 20 | Left err -> error $ "Solver isn't working: " ++ show err 21 | Right model -> 22 | error $ 23 | unlines 24 | [ "Symbolic assertion failed:", 25 | " Counterexample model: " ++ show model, 26 | " Expected value under the model: " 27 | ++ show (evalSym True model expected), 28 | " Actual value under the model: " 29 | ++ show (evalSym True model actual), 30 | " Expected value: " ++ show expected, 31 | " Actual value: " ++ show actual 32 | ] 33 | 34 | infix 1 .@?= 35 | 36 | (.@?=) :: (HasCallStack, Show a, SymEq a, EvalSym a) => a -> a -> IO () 37 | (.@?=) actual expected = 38 | symShouldEq 39 | actual 40 | expected 41 | ( \m -> 42 | "Can be not equal, model: " 43 | <> show m 44 | <> ". Actual value: " 45 | <> show (evalSym False m actual) 46 | <> ". Expected value: " 47 | <> show (evalSym False m expected) 48 | ) 49 | 50 | symShouldEq :: 51 | (HasCallStack, SymEq a) => 52 | a -> 53 | a -> 54 | (Model -> String) -> 55 | IO () 56 | symShouldEq actual expected notEqualCaseMessage = do 57 | canBeNotEqual <- solve z3 $ actual ./= expected 58 | canBeEqual <- solve z3 $ actual .== expected 59 | case (canBeNotEqual, canBeEqual) of 60 | (Left _, Right _) -> return () 61 | (Right m, _) -> error $ notEqualCaseMessage m 62 | (_, Left _) -> error "Cannot be equal" 63 | -------------------------------------------------------------------------------- /test/Grisette/Unified/GetDataTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | 11 | {- HLINT ignore "Unused LANGUAGE pragma" -} 12 | 13 | module Grisette.Unified.GetDataTest (getDataTest) where 14 | 15 | import Data.Functor.Identity (Identity (Identity)) 16 | import Grisette 17 | ( DeriveConfig (evalModeConfig), 18 | EvalModeConfig (EvalModeConstraints), 19 | Union, 20 | basicClasses0, 21 | deriveWith, 22 | ) 23 | import Grisette.TestUtil.SymbolicAssertion ((.@?=)) 24 | import Grisette.Unified (EvalModeBase, EvalModeInteger, EvalModeTag (S), GetBool, GetData, GetInteger, mrgIf, mrgIte) 25 | import Grisette.Unified.Lib.Control.Monad (mrgReturn) 26 | import Test.Framework (Test, testGroup) 27 | import Test.Framework.Providers.HUnit (testCase) 28 | import Test.HUnit ((@?=)) 29 | 30 | #if MIN_VERSION_base(4,16,0) 31 | data A mode = A (GetData mode Integer) (GetInteger mode) 32 | 33 | deriveWith 34 | mempty 35 | { evalModeConfig = 36 | [(0, EvalModeConstraints [''EvalModeBase, ''EvalModeInteger])] 37 | } 38 | [''A] 39 | basicClasses0 40 | 41 | mrgIfFunc :: 42 | (EvalModeBase mode, EvalModeInteger mode) => 43 | GetBool mode -> 44 | GetData mode (A mode) -> 45 | GetData mode (A mode) -> 46 | GetData mode (A mode) 47 | mrgIfFunc = mrgIf 48 | 49 | getDataTest :: Test 50 | getDataTest = 51 | testGroup 52 | "GetData" 53 | [ testCase "mrgIf C" $ do 54 | let a = Identity (A (Identity 1) 2) 55 | let b = Identity (A (Identity 2) 3) 56 | mrgIfFunc True a b @?= a, 57 | testCase "mrgIf S" $ do 58 | let a = mrgReturn (A (mrgReturn 1) "a") :: Union (A 'S) 59 | let b = mrgReturn (A (mrgReturn 2) "b") :: Union (A 'S) 60 | mrgIfFunc @'S "x" a b 61 | .@?= mrgReturn 62 | ( A 63 | (mrgIf @'S "x" 1 2) 64 | (mrgIte @'S "x" "a" "b") 65 | ) 66 | ] 67 | #else 68 | getDataTest = testGroup "GetData" [] 69 | #endif 70 | -------------------------------------------------------------------------------- /tutorials/README.md: -------------------------------------------------------------------------------- 1 | # Grisette Tutorials 2 | 3 | The tutorials to Grisette is provided as jupyter notebooks with the 4 | [IHaskell](https://github.com/IHaskell/IHaskell) kernel. You may run the 5 | notebooks with the following command (assuming you've already installed the 6 | IHaskell): 7 | 8 | ```bash 9 | stack install --fast 10 | ihaskell install --stack 11 | stack exec jupyter -- notebook 12 | ``` 13 | 14 | Currently, there are three tutorials available: 15 | 16 | 1. [Solve-Aided Programming with Grisette](./1_symbolic_type.ipynb). This 17 | tutorial introduces the symbolic values in Grisette and how to use them to 18 | write solve-aided programs. 19 | 1. [UnionM and Custom Data Types](./2_union.ipynb). This tutorial introduces the 20 | `UnionM` monad, which is at the core of Grisette for handling multi-path 21 | execution, and how to use it to work with custom data types in Grisette. 22 | 1. [Using Monad Transformers with Grisette](./3_monad_transformer.ipynb). This 23 | tutorial introduces monad transformers and how to use them with Grisette to 24 | build advanced program reasoning tools with error and state handling. 25 | --------------------------------------------------------------------------------