diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Changes + +## Version 0.1.0.0 +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021-2022, Sirui Lu (siruilu@cs.washington.edu) + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the developer (Sirui Lu) nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,243 @@ +# Grisette + +[![Haskell Tests](https://github.com/lsrcz/grisette/actions/workflows/test.yml/badge.svg)](https://github.com/lsrcz/grisette/actions/workflows/test.yml) + +Grisette is a symbolic evaluation library for Haskell. By translating +programs into constraints, Grisette can help the development of program +reasoning tools, including verification and synthesis. + +## Features + +- **Multi-path** symbolic evaluation with efficient (customizable) state merging. +- Symbolic evaluation is **purely functional**. The propagated symbolic value includes the assertion / error state of the execution, yet it is just a data structure. As a result, Grisette is a library that does not modify the Haskell compiler. +- The separation of symbolic and concrete values is enforced with **static types**. These types help discover opportunities for partial evaluation as well as safe use of Haskell libraries. + +## Design and Benefits + +- Modular purely functional design, with a focus on composability. + - Allows for symbolic evaluation of user-defined data structures / data + structures from third-party libraries. + - Allows for symbolic evaluation of error-handling code with user-defined + error types. + - Allows for memoization (tested and benchmarked) / parallelization (not + tested and benchmarked yet) of symbolic evaluation. +- Core multi-path symbolic evaluation semantics modeled as a monad, allowing for + easy integration with other monadic effects, for example: + - error handling via `ExceptT`, + - stateful computation via `StateT`, + - unstructured control flow via `ContT`, etc. + +## Installation + +### Install Grisette + +Grisette is available via +[Hackage](https://hackage.haskell.org/package/grisette). You can install it with +`cabal`: + +```bash +$ cabal install grisette +``` + +However, Grisette is a library and is usually used as a dependency of other +packages. You can add it to your project's `.cabal` file: + +```cabal +library + ... + build-depends: grisette >= 0.1 < 0.2 +``` + +### Install SMT Solvers + +To run the examples, you also need to install an SMT solver and make it +available through `PATH`. We recommend that you start with +[Z3](https://github.com/Z3Prover/z3), as it supports all our examples and is +usually easier to install. +[Boolector](https://github.com/Boolector/boolector) is significantly more +efficient on some examples, but it does not support all of the examples. + +#### Install Z3 + +On Ubuntu, you can install Z3 with: + +```bash +$ apt update && apt install z3 +``` + +On macOS, with [Homebrew](https://brew.sh/), you can install Z3 with: + +```bash +brew install z3 +``` + +You may also build Z3 from source, which may be more efficient on your system. +Please refer to the [Z3 homepage](https://github.com/Z3Prover/z3) for the build +instructions. + +#### Install Boolector + +Boolector from major package managers are usually outdated or inexist. We +recommend that you build Boolector from source with the CaDiCaL SAT solver, +which is usually more efficient on our examples. +Please refer to the [Boolector homepage](https://github.com/Boolector/boolector) +for the build instructions. + +## Example + +The following example uses Grisette to build a synthesizer of arithmetic programs. Given the input-output pair (2,5), the synthesizer may output the program (\x -> x+3). The example is adapted from [this blog +post](https://www.cs.utexas.edu/~bornholt/post/building-synthesizer.html) by +James Bornholt. + + +The example has three parts: +- We define the arithmetic language. The language is _symbolic_: + - its syntax tree represents a set of concrete syntax trees, and + - its interpreter accepts such symbolic syntax trees, and interprete at once all represented concrete syntax trees. +- We define the candidate program space of the synthesizer by creating a particular symbolic syntax tree. The synthesizer will search the space of concrete trees for a solution. +- We interpret the symbolic syntax tree and pass the resulting constraints to the solver. If a solution exists, the solver returns a concrete tree that agrees with the input-out example. + +### Defining the Arithmetic Language + +We will synthesize single-input programs in this example. +A single input program will be `\x -> E`, where `E` is an expression defined by +the following grammar: + +``` +E -> c -- constant + | x -- value for input variable + | E + E -- addition + | E * E -- multiplication +``` + +The syntax defines how a concrete expression is represented. To synthesis a +program, we need to define symbolic program spaces. This relies on the `UnionM` +container provided by the library to represent multiple ASTs compactly in a +single value. + +To make this expression space type work with Grisette, a set of type classes +should be derived. This includes `Mergeable`, `EvaluateSym`, etc. +The `Mergeable` type classes allows to represent multiple ASTs compactly in a +`UnionM`, while the `EvaluateSym` type class allows to evaluate it given a model +returned by a solver to replace the symbolic holes inside to concrete values. + +```haskell +data SExpr + -- `SConst` represents a constant in the syntax tree. + -- + -- `SConst 1` is the constant 1, while `SConst "c1"` is a symbolic constant, + -- and the solver can be used to find out what the concrete value should be. + = SConst SymInteger + -- `SInput` is very similar to the `SConst`, but is for inputs. We separate + -- these two mainly for clarity. + | SInput SymInteger + -- `SPlus` and `SMul` represent the addition and multiplication operators. + -- + -- The children are **sets** of symbolic programs. Here `UnionM`s are such + -- sets. + -- + -- The solver will try to pick one concrete program from the set of programs. + | SPlus (UnionM SExpr) (UnionM SExpr) + | SMul (UnionM SExpr) (UnionM SExpr) + -- `Generic` helps us derive other type class instances for `SExpr`. + deriving stock (Generic, Show) + -- Some type classes provided by Grisette for building symbolic evaluation + -- tools. See the documentation for more details. + deriving (Mergeable, EvaluateSym) + via (Default SExpr) + +-- A template haskell procedure to help the construction of `SExpr` sets. +-- +-- >>> SConst 1 :: SExpr +-- SConst 1 +-- >>> mrgSConst 1 :: UnionM SExpr +-- UMrg (Single (SConst 1)) +$(makeUnionWrapper "mrg" ''SExpr) +``` +Then we can define the program space. +The following code defines a program space `\x -> x + {x, c}`. Some example +programs in this space are `\x -> x + x`, `\x -> x + 1`, and `\x -> x + 2`. +The solver will be used to choose the right hand side of the addition. It may +choose to use the input variable `x`, or synthesize a constant `c`. + +```haskell +space :: SymInteger -> SExpr +space x = SPlus + (mrgSInput x) + (mrgIf "choice" (mrgSInput x) (mrgSConst "c")) +``` + +We then need to convert this program space to its logical encoding, and we do this by writing an interpreter to interpret all the +expressions represented by an `SExpr` all at once. The interpreter looks very +similar to a normal interpreter, except that the `onUnion` combinator is used +to lift the interpreter to work on `UnionM` values. + +```haskell +interpret :: SExpr -> SymInteger +interpret (SInt x) = x +interpret (SPlus x y) = interpretU x + interpretU y +interpret (SMul x y) = interpretU x * interpretU y + +-- interpet a set of programs +interpretU :: UnionM SExpr -> SymInteger +interpretU = onUnion interpret +``` + +And we can compose the interpreter with the program space to get it executable. + +```haskell +executableSpace :: Integer -> SymInteger +executableSpace = interpret . space . toSym +``` + +Then we can do synthesis. We call the program space on the input 2, and construct the constraint that the result is equal to 5. We then call the solver with the `solve` function. The solver is able to find a solution, and it will return the assignments to the symbolic constants as a model. + +We can then use the model to evaluate the program space, and get the synthesized program. + +```haskell +example :: IO () +example = do + Right model <- solve (UnboundedReasoning z3) $ executableSpace 2 ==~ 5 + print $ evaluateSym False model (space "x") + -- result: SPlus {SInput x} {SConst 3} + let synthesizedProgram :: Integer -> Integer = + evaluateSymToCon model . executableSpace + print $ synthesizedProgram 10 + -- result: 13 +``` + +For more details, please refer to [the Grisette examples](https://github.com/lsrcz/grisette-examples) (WIP). + +## Documentation + +- Haddock documentation at [grisette](https://hackage.haskell.org/package/grisette). +- Grisette essentials (WIP). +- Grisette tutorials (WIP). + +## License +The Grisette library is distributed under the terms of the BSD3 license. The +[LICENSE](LICENSE) file contains the full license text. + +## Citing Grisette +If you use Grisette in your research, please use the following bibtex entry: + +```bibtex +@article{10.1145/3571209, +author = {Lu, Sirui and Bod\'{\i}k, Rastislav}, +title = {Grisette: Symbolic Compilation as a Functional Programming Library}, +year = {2023}, +issue_date = {January 2023}, +publisher = {Association for Computing Machinery}, +address = {New York, NY, USA}, +volume = {7}, +number = {POPL}, +url = {https://doi.org/10.1145/3571209}, +doi = {10.1145/3571209}, +abstract = {The development of constraint solvers simplified automated reasoning about programs and shifted the engineering burden to implementing symbolic compilation tools that translate programs into efficiently solvable constraints. We describe Grisette, a reusable symbolic evaluation framework for implementing domain-specific symbolic compilers. Grisette evaluates all execution paths and merges their states into a normal form that avoids making guards mutually exclusive. This ordered-guards representation reduces the constraint size 5-fold and the solving time more than 2-fold. Grisette is designed entirely as a library, which sidesteps the complications of lifting the host language into the symbolic domain. Grisette is purely functional, enabling memoization of symbolic compilation as well as monadic integration with host libraries. Grisette is statically typed, which allows catching programming errors at compile time rather than delaying their detection to the constraint solver. We implemented Grisette in Haskell and evaluated it on benchmarks that stress both the symbolic evaluation and constraint solving.}, +journal = {Proc. ACM Program. Lang.}, +month = {jan}, +articleno = {16}, +numpages = {33}, +keywords = {State Merging, Symbolic Compilation} +} +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = do + core <- glob "src/**/*.hs" + doctest core diff --git a/grisette.cabal b/grisette.cabal new file mode 100644 --- /dev/null +++ b/grisette.cabal @@ -0,0 +1,225 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.0. +-- +-- see: https://github.com/sol/hpack + +name: grisette +version: 0.1.0.0 +synopsis: Symbolic evaluation as a library +description: Grisette is a reusable symbolic evaluation library for Haskell. By + translating programs into constraints, Grisette can help the development of + program reasoning tools, including verification, synthesis, and more. + . + This "Grisette" module exports all you need for building a symbolic evaluation + tool. + . + For more details, please checkout the README. +category: Formal Methods, Theorem Provers, Symbolic Computation, SMT +homepage: https://github.com/lsrcz/grisette-haskell#readme +bug-reports: https://github.com/lsrcz/grisette-haskell/issues +author: Sirui Lu, Rastislav Bodík +maintainer: Sirui Lu (siruilu@cs.washington.edu) +copyright: 2021-2023 Sirui Lu +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/lsrcz/grisette-haskell + +flag fast + description: Compile with O2 optimization + manual: False + default: True + +library + exposed-modules: + Grisette + Grisette.Backend.SBV + Grisette.Backend.SBV.Data.SMT.Lowering + Grisette.Backend.SBV.Data.SMT.Solving + Grisette.Backend.SBV.Data.SMT.SymBiMap + Grisette.Core + Grisette.Core.BuiltinUnionWrappers + Grisette.Core.Control.Exception + Grisette.Core.Control.Monad.CBMCExcept + Grisette.Core.Control.Monad.Union + Grisette.Core.Control.Monad.UnionM + Grisette.Core.Data.Class.BitVector + Grisette.Core.Data.Class.Bool + Grisette.Core.Data.Class.CEGISSolver + Grisette.Core.Data.Class.Error + Grisette.Core.Data.Class.Evaluate + Grisette.Core.Data.Class.ExtractSymbolics + Grisette.Core.Data.Class.Function + Grisette.Core.Data.Class.GenSym + Grisette.Core.Data.Class.Integer + Grisette.Core.Data.Class.Mergeable + Grisette.Core.Data.Class.ModelOps + Grisette.Core.Data.Class.SimpleMergeable + Grisette.Core.Data.Class.Solvable + Grisette.Core.Data.Class.Solver + Grisette.Core.Data.Class.SOrd + Grisette.Core.Data.Class.Substitute + Grisette.Core.Data.Class.ToCon + Grisette.Core.Data.Class.ToSym + Grisette.Core.Data.FileLocation + Grisette.Core.Data.MemoUtils + Grisette.Core.Data.Union + Grisette.Core.TH + Grisette.Core.THCompat + Grisette.Internal.Backend.SBV + Grisette.Internal.Core + Grisette.Internal.IR.SymPrim + Grisette.IR.SymPrim + Grisette.IR.SymPrim.Data.BV + Grisette.IR.SymPrim.Data.IntBitwidth + Grisette.IR.SymPrim.Data.Prim.Helpers + Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches + Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors + Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm + Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution + Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils + Grisette.IR.SymPrim.Data.Prim.Model + Grisette.IR.SymPrim.Data.Prim.ModelValue + Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits + Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool + Grisette.IR.SymPrim.Data.Prim.PartialEval.BV + Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun + Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer + Grisette.IR.SymPrim.Data.Prim.PartialEval.Num + Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval + Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun + Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold + Grisette.IR.SymPrim.Data.Prim.Utils + Grisette.IR.SymPrim.Data.SymPrim + Grisette.IR.SymPrim.Data.TabularFun + Grisette.Lib.Base + Grisette.Lib.Control.Monad + Grisette.Lib.Control.Monad.Except + Grisette.Lib.Control.Monad.Trans + Grisette.Lib.Control.Monad.Trans.Cont + Grisette.Lib.Data.Foldable + Grisette.Lib.Data.List + Grisette.Lib.Data.Traversable + Grisette.Lib.Mtl + other-modules: + Paths_grisette + hs-source-dirs: + src + build-depends: + array >=0.5.4 && <0.6 + , base >4.14 && <5 + , bytestring >=0.10.12 && <0.12 + , call-stack >=0.1 && <0.5 + , deepseq >=1.4.4 && <1.5 + , generic-deriving >=1.14.1 && <1.15 + , hashable >=1.2.3 && <1.5 + , hashtables >=1.2.3.4 && <1.4 + , intern >=0.9.2 && <0.10 + , loch-th >=0.2.2 && <0.3 + , mtl >=2.2.2 && <2.3 + , once >=0.2 && <0.5 + , sbv >=8.11 && <9.1 + , template-haskell >=2.16 && <2.20 + , th-compat >=0.1.2 && <0.2 + , transformers >=0.5.6 && <0.6 + , unordered-containers >=0.2.11 && <0.3 + , vector >=0.12.1 && <0.14 + default-language: Haskell2010 + if flag(fast) + ghc-options: -O2 + else + ghc-options: -O0 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_grisette + hs-source-dirs: + doctest + build-depends: + Glob + , array >=0.5.4 && <0.6 + , base >4.14 && <5 + , bytestring >=0.10.12 && <0.12 + , call-stack >=0.1 && <0.5 + , deepseq >=1.4.4 && <1.5 + , doctest >=0.18.2 && <0.21 + , generic-deriving >=1.14.1 && <1.15 + , grisette + , hashable >=1.2.3 && <1.5 + , hashtables >=1.2.3.4 && <1.4 + , intern >=0.9.2 && <0.10 + , loch-th >=0.2.2 && <0.3 + , mtl >=2.2.2 && <2.3 + , once >=0.2 && <0.5 + , sbv >=8.11 && <9.1 + , template-haskell >=2.16 && <2.20 + , th-compat >=0.1.2 && <0.2 + , transformers >=0.5.6 && <0.6 + , unordered-containers >=0.2.11 && <0.3 + , vector >=0.12.1 && <0.14 + default-language: Haskell2010 + if flag(fast) + ghc-options: -O2 + else + ghc-options: -O0 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Grisette.Backend.SBV.Data.SMT.CEGISTests + Grisette.Backend.SBV.Data.SMT.LoweringTests + Grisette.Backend.SBV.Data.SMT.TermRewritingGen + Grisette.Backend.SBV.Data.SMT.TermRewritingTests + Grisette.IR.SymPrim.Data.BVTests + Grisette.IR.SymPrim.Data.Prim.BitsTests + Grisette.IR.SymPrim.Data.Prim.BoolTests + Grisette.IR.SymPrim.Data.Prim.BVTests + Grisette.IR.SymPrim.Data.Prim.IntegerTests + Grisette.IR.SymPrim.Data.Prim.ModelTests + Grisette.IR.SymPrim.Data.Prim.NumTests + Grisette.IR.SymPrim.Data.Prim.TabularFunTests + Grisette.IR.SymPrim.Data.SymPrimTests + Grisette.IR.SymPrim.Data.TabularFunTests + Paths_grisette + hs-source-dirs: + test + build-depends: + array >=0.5.4 && <0.6 + , base >4.14 && <5 + , bytestring >=0.10.12 && <0.12 + , call-stack >=0.1 && <0.5 + , deepseq >=1.4.4 && <1.5 + , generic-deriving >=1.14.1 && <1.15 + , grisette + , hashable >=1.2.3 && <1.5 + , hashtables >=1.2.3.4 && <1.4 + , intern >=0.9.2 && <0.10 + , loch-th >=0.2.2 && <0.3 + , mtl >=2.2.2 && <2.3 + , once >=0.2 && <0.5 + , sbv >=8.11 && <9.1 + , tasty >=1.1.0.3 && <1.5 + , tasty-hunit ==0.10.* + , tasty-quickcheck >=0.10.1 && <0.11 + , tasty-test-reporter >=0.1.1.2 && <0.2 + , template-haskell >=2.16 && <2.20 + , th-compat >=0.1.2 && <0.2 + , transformers >=0.5.6 && <0.6 + , unordered-containers >=0.2.11 && <0.3 + , vector >=0.12.1 && <0.14 + default-language: Haskell2010 + if flag(fast) + ghc-options: -O2 + else + ghc-options: -O0 diff --git a/src/Grisette.hs b/src/Grisette.hs new file mode 100644 --- /dev/null +++ b/src/Grisette.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Grisette.Core +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette + ( -- * Core modules + module Grisette.Core, + + -- * Core libraries + module Grisette.Lib.Base, + module Grisette.Lib.Mtl, + + -- * Symbolic primitives + module Grisette.IR.SymPrim, + + -- * Solver backend + module Grisette.Backend.SBV, + ) +where + +import Grisette.Backend.SBV +import Grisette.Core +import Grisette.IR.SymPrim +import Grisette.Lib.Base +import Grisette.Lib.Mtl diff --git a/src/Grisette/Backend/SBV.hs b/src/Grisette/Backend/SBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Backend/SBV.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Grisette.Backend.SBV +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Backend.SBV + ( -- * Grisette SBV backend configuration + GrisetteSMTConfig (..), + sbvConfig, + + -- * SBV backend solver configuration + SBV.SMTConfig (..), + SBV.boolector, + SBV.cvc4, + SBV.yices, + SBV.dReal, + SBV.z3, + SBV.mathSAT, + SBV.abc, + SBV.Timing (..), + ) +where + +import qualified Data.SBV as SBV +import Grisette.Backend.SBV.Data.SMT.Solving diff --git a/src/Grisette/Backend/SBV/Data/SMT/Lowering.hs b/src/Grisette/Backend/SBV/Data/SMT/Lowering.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Backend/SBV/Data/SMT/Lowering.hs @@ -0,0 +1,1217 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Backend.SBV.Data.SMT.Lowering +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Backend.SBV.Data.SMT.Lowering + ( lowerSinglePrim, + lowerSinglePrim', + parseModel, + SymBiMap, + ) +where + +import Control.Monad.State.Strict +import Data.Bifunctor +import Data.Bits +import Data.Dynamic +import Data.Foldable +import Data.Kind +import Data.Maybe +import qualified Data.SBV as SBV +import qualified Data.SBV.Internals as SBVI +import Data.Type.Equality (type (~~)) +import Data.Typeable +import GHC.Exts (sortWith) +import GHC.Natural +import GHC.Stack +import GHC.TypeNats +import {-# SOURCE #-} Grisette.Backend.SBV.Data.SMT.Solving +import Grisette.Backend.SBV.Data.SMT.SymBiMap +import Grisette.Core.Data.Class.ModelOps +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.Prim.Model as PM +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.TabularFun +import qualified Type.Reflection as R +import Unsafe.Coerce + +newtype NatRepr (n :: Nat) = NatRepr Natural + +withKnownNat :: forall n r. NatRepr n -> (KnownNat n => r) -> r +withKnownNat (NatRepr nVal) v = + case someNatVal nVal of + SomeNat (Proxy :: Proxy n') -> + case unsafeAxiom :: n :~: n' of + Refl -> v + +data LeqProof (m :: Nat) (n :: Nat) where + LeqProof :: m <= n => LeqProof m n + +-- | Assert a proof of equality between two types. +-- This is unsafe if used improperly, so use this with caution! +unsafeAxiom :: forall a b. a :~: b +unsafeAxiom = unsafeCoerce (Refl @a) +{-# NOINLINE unsafeAxiom #-} -- Note [Mark unsafe axioms as NOINLINE] + +unsafeLeqProof :: forall m n. LeqProof m n +unsafeLeqProof = unsafeCoerce (LeqProof @0 @0) +{-# NOINLINE unsafeLeqProof #-} -- Note [Mark unsafe axioms as NOINLINE] + +cachedResult :: + forall integerBitWidth a. + (SupportedPrim a, Typeable (TermTy integerBitWidth a)) => + Term a -> + State SymBiMap (Maybe (TermTy integerBitWidth a)) +cachedResult t = gets $ \m -> do + d <- lookupTerm (SomeTerm t) m + Just $ fromDyn d undefined + +addResult :: + forall integerBitWidth a. + (SupportedPrim a, Typeable (TermTy integerBitWidth a)) => + Term a -> + TermTy integerBitWidth a -> + State SymBiMap () +addResult tm sbvtm = modify $ addBiMapIntermediate (SomeTerm tm) (toDyn sbvtm) + +lowerSinglePrim' :: + forall integerBitWidth a. + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + (TermTy integerBitWidth a, SymBiMap) +lowerSinglePrim' config t = runState (lowerSinglePrimCached' config t) + +lowerSinglePrimCached' :: + forall integerBitWidth a. + GrisetteSMTConfig integerBitWidth -> + Term a -> + State SymBiMap (TermTy integerBitWidth a) +lowerSinglePrimCached' config t = introSupportedPrimConstraint t $ + case (config, R.typeRep @a) of + ResolvedDeepType -> do + r <- cachedResult @integerBitWidth t + case r of + Just v -> return v + _ -> lowerSinglePrimImpl' config t + _ -> translateTypeError (R.typeRep @a) + +lowerUnaryTerm' :: + forall integerBitWidth a a1 x x1. + (Typeable x1, a1 ~ TermTy integerBitWidth a, SupportedPrim x, x1 ~ TermTy integerBitWidth x) => + GrisetteSMTConfig integerBitWidth -> + Term x -> + Term a -> + (a1 -> x1) -> + State SymBiMap (TermTy integerBitWidth x) +lowerUnaryTerm' config orig t1 f = do + l1 <- lowerSinglePrimCached' config t1 + let g = f l1 + addResult @integerBitWidth orig g + return g + +lowerBinaryTerm' :: + forall integerBitWidth a b a1 b1 x. + ( Typeable (TermTy integerBitWidth x), + a1 ~ TermTy integerBitWidth a, + b1 ~ TermTy integerBitWidth b, + SupportedPrim x + ) => + GrisetteSMTConfig integerBitWidth -> + Term x -> + Term a -> + Term b -> + (a1 -> b1 -> TermTy integerBitWidth x) -> + State SymBiMap (TermTy integerBitWidth x) +lowerBinaryTerm' config orig t1 t2 f = do + l1 <- lowerSinglePrimCached' config t1 + l2 <- lowerSinglePrimCached' config t2 + let g = f l1 l2 + addResult @integerBitWidth orig g + return g + +lowerSinglePrimImpl' :: + forall integerBitWidth a. + GrisetteSMTConfig integerBitWidth -> + Term a -> + State SymBiMap (TermTy integerBitWidth a) +lowerSinglePrimImpl' ResolvedConfig {} (ConTerm _ v) = + case R.typeRep @a of + BoolType -> return $ if v then SBV.sTrue else SBV.sFalse + IntegerType -> return $ fromInteger v + SignedBVType _ -> case v of + IntN x -> return $ fromInteger x + UnsignedBVType _ -> case v of + WordN x -> return $ fromInteger x + _ -> translateTypeError (R.typeRep @a) +lowerSinglePrimImpl' _ t@SymTerm {} = + error $ + "The symbolic term should have already been lowered " + ++ show t + ++ " to SMT with collectedPrims.\n" + ++ "We don't support adding new symbolics after collectedPrims with SBV backend" +lowerSinglePrimImpl' _ (UnaryTerm _ op (_ :: Term x)) = errorMsg + where + errorMsg :: forall t1. t1 + errorMsg = translateUnaryError (show op) (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl' _ (BinaryTerm _ op (_ :: Term x) (_ :: Term y)) = errorMsg + where + errorMsg :: forall t1. t1 + errorMsg = translateBinaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @a) +lowerSinglePrimImpl' ResolvedConfig {} (TernaryTerm _ op (_ :: Term x) (_ :: Term y) (_ :: Term z)) = errorMsg + where + errorMsg :: forall t1. t1 + errorMsg = translateTernaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @z) (R.typeRep @a) +lowerSinglePrimImpl' config t@(NotTerm _ arg) = lowerUnaryTerm' config t arg SBV.sNot +lowerSinglePrimImpl' config t@(OrTerm _ arg1 arg2) = lowerBinaryTerm' config t arg1 arg2 (SBV..||) +lowerSinglePrimImpl' config t@(AndTerm _ arg1 arg2) = lowerBinaryTerm' config t arg1 arg2 (SBV..&&) +lowerSinglePrimImpl' config t@(EqvTerm _ (arg1 :: Term x) arg2) = + case (config, R.typeRep @x) of + ResolvedSimpleType -> lowerBinaryTerm' config t arg1 arg2 (SBV..==) + _ -> translateBinaryError "(==)" (R.typeRep @x) (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl' config t@(ITETerm _ cond arg1 arg2) = + case (config, R.typeRep @a) of + ResolvedSimpleType -> do + l1 <- lowerSinglePrimCached' config cond + l2 <- lowerSinglePrimCached' config arg1 + l3 <- lowerSinglePrimCached' config arg2 + let g = SBV.ite l1 l2 l3 + addResult @integerBitWidth t g + return g + _ -> translateTernaryError "ite" (R.typeRep @Bool) (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(AddNumTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerBinaryTerm' config t arg1 arg2 (+) + _ -> translateBinaryError "(+)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(UMinusNumTerm _ arg) = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerUnaryTerm' config t arg negate + _ -> translateUnaryError "negate" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(TimesNumTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerBinaryTerm' config t arg1 arg2 (*) + _ -> translateBinaryError "(*)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(AbsNumTerm _ arg) = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerUnaryTerm' config t arg abs + _ -> translateUnaryError "abs" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(SignumNumTerm _ arg) = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerUnaryTerm' config t arg signum + _ -> translateUnaryError "signum" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(LTNumTerm _ (arg1 :: Term arg) arg2) = + case (config, R.typeRep @arg) of + ResolvedNumOrdType -> lowerBinaryTerm' config t arg1 arg2 (SBV..<) + _ -> translateBinaryError "(<)" (R.typeRep @arg) (R.typeRep @arg) (R.typeRep @Bool) +lowerSinglePrimImpl' config t@(LENumTerm _ (arg1 :: Term arg) arg2) = + case (config, R.typeRep @arg) of + ResolvedNumOrdType -> lowerBinaryTerm' config t arg1 arg2 (SBV..<=) + _ -> translateBinaryError "(<=)" (R.typeRep @arg) (R.typeRep @arg) (R.typeRep @Bool) +lowerSinglePrimImpl' config t@(AndBitsTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerBinaryTerm' config t arg1 arg2 (.&.) + _ -> translateBinaryError "(.&.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(OrBitsTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerBinaryTerm' config t arg1 arg2 (.|.) + _ -> translateBinaryError "(.|.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(XorBitsTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerBinaryTerm' config t arg1 arg2 xor + _ -> translateBinaryError "xor" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(ComplementBitsTerm _ arg) = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerUnaryTerm' config t arg complement + _ -> translateUnaryError "complement" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(ShiftBitsTerm _ arg n) = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerUnaryTerm' config t arg (`shift` n) + _ -> translateBinaryError "shift" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) +lowerSinglePrimImpl' config t@(RotateBitsTerm _ arg n) = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerUnaryTerm' config t arg (`rotate` n) + _ -> translateBinaryError "rotate" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) +lowerSinglePrimImpl' config t@(BVConcatTerm _ (bv1 :: Term x) (bv2 :: Term y)) = + case (R.typeRep @a, R.typeRep @x, R.typeRep @y) of + (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx), UnsignedBVType (_ :: Proxy ny)) -> + case (unsafeAxiom @(nx + ny) @na) of + Refl -> lowerBinaryTerm' config t bv1 bv2 (SBV.#) + (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx), SignedBVType (_ :: Proxy ny)) -> + case (unsafeAxiom @(nx + ny) @na) of + Refl -> + lowerBinaryTerm' + config + t + bv1 + bv2 + ( \(x :: SBV.SInt xn) (y :: SBV.SInt yn) -> + SBV.sFromIntegral $ + (SBV.sFromIntegral x :: SBV.SWord xn) SBV.# (SBV.sFromIntegral y :: SBV.SWord yn) + ) + _ -> translateBinaryError "bvconcat" (R.typeRep @x) (R.typeRep @y) (R.typeRep @a) +lowerSinglePrimImpl' config t@(BVSelectTerm _ (ix :: R.TypeRep ix) w (bv :: Term x)) = + case (R.typeRep @a, R.typeRep @x) of + (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy xn)) -> + withKnownNat n1 $ + case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na, + unsafeLeqProof @(na + ix - 1 + 1) @xn, + unsafeLeqProof @ix @(na + ix - 1) + ) of + (Refl, LeqProof, LeqProof) -> + lowerUnaryTerm' config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) + where + n1 :: NatRepr (na + ix - 1) + n1 = NatRepr (natVal (Proxy @na) + natVal (Proxy @ix) - 1) + (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy xn)) -> + withKnownNat n1 $ + case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na, + unsafeLeqProof @(na + ix - 1 + 1) @xn, + unsafeLeqProof @ix @(na + ix - 1) + ) of + (Refl, LeqProof, LeqProof) -> + lowerUnaryTerm' config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) + where + n1 :: NatRepr (na + ix - 1) + n1 = NatRepr (natVal (Proxy @na) + natVal (Proxy @ix) - 1) + _ -> translateTernaryError "bvselect" ix w (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl' config t@(BVExtendTerm _ signed (n :: R.TypeRep n) (bv :: Term x)) = + case (R.typeRep @a, R.typeRep @x) of + (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx)) -> + withKnownNat (NatRepr (natVal (Proxy @na) - natVal (Proxy @nx)) :: NatRepr (na - nx)) $ + case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of + (LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 @(na - nx) $ + lowerUnaryTerm' config t bv (if signed then SBV.signExtend else SBV.zeroExtend) + (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx)) -> + withKnownNat (NatRepr (natVal (Proxy @na) - natVal (Proxy @nx)) :: NatRepr (na - nx)) $ + case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of + (LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 @(na - nx) $ + lowerUnaryTerm' + config + t + bv + ( if signed + then SBV.signExtend + else \x -> + SBV.sFromIntegral + (SBV.zeroExtend (SBV.sFromIntegral x :: SBV.SBV (SBV.WordN nx)) :: SBV.SBV (SBV.WordN na)) + ) + _ -> translateTernaryError "bvextend" (R.typeRep @Bool) n (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl' config t@(TabularFunApplyTerm _ (f :: Term (b =-> a)) (arg :: Term b)) = + case (config, R.typeRep @a) of + ResolvedDeepType -> do + l1 <- lowerSinglePrimCached' config f + l2 <- lowerSinglePrimCached' config arg + let g = l1 l2 + addResult @integerBitWidth t g + return g + _ -> translateBinaryError "tabularApply" (R.typeRep @(b =-> a)) (R.typeRep @b) (R.typeRep @a) +lowerSinglePrimImpl' config t@(GeneralFunApplyTerm _ (f :: Term (b --> a)) (arg :: Term b)) = + case (config, R.typeRep @a) of + ResolvedDeepType -> do + l1 <- lowerSinglePrimCached' config f + l2 <- lowerSinglePrimCached' config arg + let g = l1 l2 + addResult @integerBitWidth t g + return g + _ -> translateBinaryError "generalApply" (R.typeRep @(b --> a)) (R.typeRep @b) (R.typeRep @a) +lowerSinglePrimImpl' config t@(DivIntegerTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + (ResolvedConfig {}, IntegerType) -> lowerBinaryTerm' config t arg1 arg2 SBV.sDiv + _ -> translateBinaryError "div" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' config t@(ModIntegerTerm _ arg1 arg2) = + case (config, R.typeRep @a) of + (ResolvedConfig {}, IntegerType) -> lowerBinaryTerm' config t arg1 arg2 SBV.sMod + _ -> translateBinaryError "mod" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl' _ _ = undefined + +buildUTFun11 :: + forall integerBitWidth s1 s2 a. + (SupportedPrim a, SupportedPrim s1, SupportedPrim s2) => + GrisetteSMTConfig integerBitWidth -> + R.TypeRep s1 -> + R.TypeRep s2 -> + Term a -> + SymBiMap -> + Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth (s1 =-> s2))) +buildUTFun11 config ta tb term@(SymTerm _ ts) m = case ((config, ta), (config, tb)) of + (ResolvedSimpleType, ResolvedSimpleType) -> + let name = "ufunc_" ++ show (sizeBiMap m) + f = SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2) name + in Just $ return (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) + _ -> Nothing +buildUTFun11 _ _ _ _ _ = error "Should only be called on SymTerm" + +buildUTFun111 :: + forall integerBitWidth s1 s2 s3 a. + (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3) => + GrisetteSMTConfig integerBitWidth -> + R.TypeRep s1 -> + R.TypeRep s2 -> + R.TypeRep s3 -> + Term a -> + SymBiMap -> + Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3))) +buildUTFun111 config ta tb tc term@(SymTerm _ ts) m = case ((config, ta), (config, tb), (config, tc)) of + (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> + let name = "ufunc_" ++ show (sizeBiMap m) + f = + SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3) + name + in Just $ return (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) + _ -> Nothing +buildUTFun111 _ _ _ _ _ _ = error "Should only be called on SymTerm" + +buildUGFun11 :: + forall integerBitWidth s1 s2 a. + (SupportedPrim a, SupportedPrim s1, SupportedPrim s2) => + GrisetteSMTConfig integerBitWidth -> + R.TypeRep s1 -> + R.TypeRep s2 -> + Term a -> + SymBiMap -> + Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth (s1 --> s2))) +buildUGFun11 config ta tb term@(SymTerm _ ts) m = case ((config, ta), (config, tb)) of + (ResolvedSimpleType, ResolvedSimpleType) -> + let name = "ufunc_" ++ show (sizeBiMap m) + f = SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2) name + in Just $ return (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) + _ -> Nothing +buildUGFun11 _ _ _ _ _ = error "Should only be called on SymTerm" + +buildUGFun111 :: + forall integerBitWidth s1 s2 s3 a. + (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3) => + GrisetteSMTConfig integerBitWidth -> + R.TypeRep s1 -> + R.TypeRep s2 -> + R.TypeRep s3 -> + Term a -> + SymBiMap -> + Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3))) +buildUGFun111 config ta tb tc term@(SymTerm _ ts) m = case ((config, ta), (config, tb), (config, tc)) of + (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> + let name = "ufunc_" ++ show (sizeBiMap m) + f = + SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3) + name + in Just $ return (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) + _ -> Nothing +buildUGFun111 _ _ _ _ _ _ = error "Should only be called on SymTerm" + +lowerSinglePrimUFun :: + forall integerBitWidth a. + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth a)) +lowerSinglePrimUFun config t@(SymTerm _ _) m = + case R.typeRep @a of + TFun3Type (t1 :: R.TypeRep a1) (t2 :: R.TypeRep a2) (t3 :: R.TypeRep a3) -> buildUTFun111 config t1 t2 t3 t m + TFunType (ta :: R.TypeRep b) (tb :: R.TypeRep b1) -> buildUTFun11 config ta tb t m + GFun3Type (t1 :: R.TypeRep a1) (t2 :: R.TypeRep a2) (t3 :: R.TypeRep a3) -> buildUGFun111 config t1 t2 t3 t m + GFunType (ta :: R.TypeRep b) (tb :: R.TypeRep b1) -> buildUGFun11 config ta tb t m + _ -> Nothing +lowerSinglePrimUFun _ _ _ = error "Should not call this function" + +lowerUnaryTerm :: + forall integerBitWidth a a1 x x1. + (Typeable x1, a1 ~ TermTy integerBitWidth a, SupportedPrim x, HasCallStack) => + GrisetteSMTConfig integerBitWidth -> + Term x -> + Term a -> + (a1 -> x1) -> + SymBiMap -> + SBV.Symbolic (SymBiMap, x1) +lowerUnaryTerm config orig t1 f m = do + (m1, l1) <- lowerSinglePrimCached config t1 m + let g = f l1 + return (addBiMapIntermediate (SomeTerm orig) (toDyn g) m1, g) + +lowerBinaryTerm :: + forall integerBitWidth a b a1 b1 x x1. + (Typeable x1, a1 ~ TermTy integerBitWidth a, b1 ~ TermTy integerBitWidth b, SupportedPrim x, HasCallStack) => + GrisetteSMTConfig integerBitWidth -> + Term x -> + Term a -> + Term b -> + (a1 -> b1 -> x1) -> + SymBiMap -> + SBV.Symbolic (SymBiMap, x1) +lowerBinaryTerm config orig t1 t2 f m = do + (m1, l1) <- lowerSinglePrimCached config t1 m + (m2, l2) <- lowerSinglePrimCached config t2 m1 + let g = f l1 l2 + return (addBiMapIntermediate (SomeTerm orig) (toDyn g) m2, g) + +lowerSinglePrimCached :: + forall integerBitWidth a. + HasCallStack => + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + SBV.Symbolic (SymBiMap, TermTy integerBitWidth a) +lowerSinglePrimCached config t m = + introSupportedPrimConstraint t $ + case (config, R.typeRep @a) of + ResolvedDeepType -> + case lookupTerm (SomeTerm t) m of + Just x -> return (m, fromDyn x undefined) + Nothing -> lowerSinglePrimImpl config t m + _ -> translateTypeError (R.typeRep @a) + +lowerSinglePrim :: + forall integerBitWidth a. + HasCallStack => + GrisetteSMTConfig integerBitWidth -> + Term a -> + SBV.Symbolic (SymBiMap, TermTy integerBitWidth a) +lowerSinglePrim config t = lowerSinglePrimCached config t emptySymBiMap + +translateTypeError :: HasCallStack => R.TypeRep a -> b +translateTypeError ta = + error $ + "Don't know how to translate the type " ++ show ta ++ " to SMT" + +translateUnaryError :: HasCallStack => String -> R.TypeRep a -> R.TypeRep b -> c +translateUnaryError op ta tb = + error $ + "Don't know how to translate the op " + ++ show op + ++ " :: " + ++ show ta + ++ " -> " + ++ show tb + ++ " to SMT" + +translateBinaryError :: HasCallStack => String -> R.TypeRep a -> R.TypeRep b -> R.TypeRep c -> d +translateBinaryError op ta tb tc = + error $ + "Don't know how to translate the op " + ++ show op + ++ " :: " + ++ show ta + ++ " -> " + ++ show tb + ++ " -> " + ++ show tc + ++ " to SMT" + +translateTernaryError :: HasCallStack => String -> R.TypeRep a -> R.TypeRep b -> R.TypeRep c -> R.TypeRep d -> e +translateTernaryError op ta tb tc td = + error $ + "Don't know how to translate the op " + ++ show op + ++ " :: " + ++ show ta + ++ " -> " + ++ show tb + ++ " -> " + ++ show tc + ++ " -> " + ++ show td + ++ " to SMT" + +lowerSinglePrimImpl :: + forall integerBitWidth a. + HasCallStack => + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + SBV.Symbolic (SymBiMap, TermTy integerBitWidth a) +lowerSinglePrimImpl ResolvedConfig {} (ConTerm _ v) m = + case R.typeRep @a of + BoolType -> return (m, if v then SBV.sTrue else SBV.sFalse) + IntegerType -> return (m, fromInteger v) + SignedBVType _ -> case v of + IntN x -> return (m, fromInteger x) + UnsignedBVType _ -> case v of + WordN x -> return (m, fromInteger x) + _ -> translateTypeError (R.typeRep @a) +lowerSinglePrimImpl config t@(SymTerm _ ts) m = + fromMaybe errorMsg $ asum [simple, ufunc] + where + errorMsg :: forall x. x + errorMsg = translateTypeError (R.typeRep @a) + simple :: Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth a)) + simple = case (config, R.typeRep @a) of + ResolvedSimpleType -> Just $ do + let name = show ts + (g :: TermTy integerBitWidth a) <- SBV.free name + return (addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) m, g) + _ -> Nothing + ufunc :: (Maybe (SBV.Symbolic (SymBiMap, TermTy integerBitWidth a))) + ufunc = lowerSinglePrimUFun config t m +lowerSinglePrimImpl _ (UnaryTerm _ op (_ :: Term x)) _ = errorMsg + where + errorMsg :: forall t1. t1 + errorMsg = translateUnaryError (show op) (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl _ (BinaryTerm _ op (_ :: Term x) (_ :: Term y)) _ = errorMsg + where + errorMsg :: forall t1. t1 + errorMsg = translateBinaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @a) +lowerSinglePrimImpl ResolvedConfig {} (TernaryTerm _ op (_ :: Term x) (_ :: Term y) (_ :: Term z)) _ = errorMsg + where + errorMsg :: forall t1. t1 + errorMsg = translateTernaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @z) (R.typeRep @a) +lowerSinglePrimImpl config t@(NotTerm _ arg) m = lowerUnaryTerm config t arg SBV.sNot m +lowerSinglePrimImpl config t@(OrTerm _ arg1 arg2) m = lowerBinaryTerm config t arg1 arg2 (SBV..||) m +lowerSinglePrimImpl config t@(AndTerm _ arg1 arg2) m = lowerBinaryTerm config t arg1 arg2 (SBV..&&) m +lowerSinglePrimImpl config t@(EqvTerm _ (arg1 :: Term x) arg2) m = + case (config, R.typeRep @x) of + ResolvedSimpleType -> lowerBinaryTerm config t arg1 arg2 (SBV..==) m + _ -> translateBinaryError "(==)" (R.typeRep @x) (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl config t@(ITETerm _ cond arg1 arg2) m = + case (config, R.typeRep @a) of + ResolvedSimpleType -> do + (m1, l1) <- lowerSinglePrimCached config cond m + (m2, l2) <- lowerSinglePrimCached config arg1 m1 + (m3, l3) <- lowerSinglePrimCached config arg2 m2 + let g = SBV.ite l1 l2 l3 + return (addBiMapIntermediate (SomeTerm t) (toDyn g) m3, g) + _ -> translateBinaryError "ite" (R.typeRep @Bool) (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(AddNumTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerBinaryTerm config t arg1 arg2 (+) m + _ -> translateBinaryError "(+)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(UMinusNumTerm _ arg) m = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerUnaryTerm config t arg negate m + _ -> translateUnaryError "negate" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(TimesNumTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerBinaryTerm config t arg1 arg2 (*) m + _ -> translateBinaryError "(*)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(AbsNumTerm _ arg) m = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerUnaryTerm config t arg abs m + _ -> translateUnaryError "abs" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(SignumNumTerm _ arg) m = + case (config, R.typeRep @a) of + ResolvedNumType -> lowerUnaryTerm config t arg signum m + _ -> translateUnaryError "signum" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(LTNumTerm _ (arg1 :: Term arg) arg2) m = + case (config, R.typeRep @arg) of + ResolvedNumOrdType -> lowerBinaryTerm config t arg1 arg2 (SBV..<) m + _ -> translateBinaryError "(<)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @Bool) +lowerSinglePrimImpl config t@(LENumTerm _ (arg1 :: Term arg) arg2) m = + case (config, R.typeRep @arg) of + ResolvedNumOrdType -> lowerBinaryTerm config t arg1 arg2 (SBV..<=) m + _ -> translateBinaryError "(<=)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @Bool) +lowerSinglePrimImpl config t@(AndBitsTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 (.&.) m + _ -> translateBinaryError "(.&.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(OrBitsTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 (.|.) m + _ -> translateBinaryError "(.|.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(XorBitsTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 xor m + _ -> translateBinaryError "xor" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(ComplementBitsTerm _ arg) m = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerUnaryTerm config t arg complement m + _ -> translateUnaryError "complement" (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(ShiftBitsTerm _ arg n) m = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerUnaryTerm config t arg (`shift` n) m + _ -> translateBinaryError "shift" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) +lowerSinglePrimImpl config t@(RotateBitsTerm _ arg n) m = + case (config, R.typeRep @a) of + ResolvedBitsType -> lowerUnaryTerm config t arg (`rotate` n) m + _ -> translateBinaryError "rotate" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) +lowerSinglePrimImpl config t@(BVConcatTerm _ (bv1 :: Term x) (bv2 :: Term y)) m = + case (R.typeRep @a, R.typeRep @x, R.typeRep @y) of + (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx), UnsignedBVType (_ :: Proxy ny)) -> + case (unsafeAxiom @(nx + ny) @na) of + Refl -> lowerBinaryTerm config t bv1 bv2 (SBV.#) m + (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx), SignedBVType (_ :: Proxy ny)) -> + case (unsafeAxiom @(nx + ny) @na) of + Refl -> + lowerBinaryTerm + config + t + bv1 + bv2 + ( \(x :: SBV.SInt xn) (y :: SBV.SInt yn) -> + SBV.sFromIntegral $ + (SBV.sFromIntegral x :: SBV.SWord xn) SBV.# (SBV.sFromIntegral y :: SBV.SWord yn) + ) + m + _ -> translateBinaryError "bvconcat" (R.typeRep @x) (R.typeRep @y) (R.typeRep @a) +lowerSinglePrimImpl config t@(BVSelectTerm _ (ix :: R.TypeRep ix) w (bv :: Term x)) m = + case (R.typeRep @a, R.typeRep @x) of + (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy xn)) -> + withKnownNat n1 $ + case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na, + unsafeLeqProof @(na + ix - 1 + 1) @xn, + unsafeLeqProof @ix @(na + ix - 1) + ) of + (Refl, LeqProof, LeqProof) -> + lowerUnaryTerm config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) m + where + n1 :: NatRepr (na + ix - 1) + n1 = NatRepr (natVal (Proxy @na) + natVal (Proxy @ix) - 1) + (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy xn)) -> + withKnownNat n1 $ + case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na, + unsafeLeqProof @(na + ix - 1 + 1) @xn, + unsafeLeqProof @ix @(na + ix - 1) + ) of + (Refl, LeqProof, LeqProof) -> + lowerUnaryTerm config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) m + where + n1 :: NatRepr (na + ix - 1) + n1 = NatRepr (natVal (Proxy @na) + natVal (Proxy @ix) - 1) + _ -> translateTernaryError "bvselect" ix w (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl config t@(BVExtendTerm _ signed (n :: R.TypeRep n) (bv :: Term x)) m = + case (R.typeRep @a, R.typeRep @x) of + (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx)) -> + withKnownNat (NatRepr (natVal (Proxy @na) - natVal (Proxy @nx)) :: NatRepr (na - nx)) $ + case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of + (LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 @(na - nx) $ + lowerUnaryTerm config t bv (if signed then SBV.signExtend else SBV.zeroExtend) m + (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx)) -> + withKnownNat (NatRepr (natVal (Proxy @na) - natVal (Proxy @nx)) :: NatRepr (na - nx)) $ + case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of + (LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 @(na - nx) $ + lowerUnaryTerm + config + t + bv + ( if signed + then SBV.signExtend + else \x -> + SBV.sFromIntegral + (SBV.zeroExtend (SBV.sFromIntegral x :: SBV.SBV (SBV.WordN nx)) :: SBV.SBV (SBV.WordN na)) + ) + m + _ -> translateTernaryError "bvextend" (R.typeRep @Bool) n (R.typeRep @x) (R.typeRep @a) +lowerSinglePrimImpl config t@(TabularFunApplyTerm _ (f :: Term (b =-> a)) (arg :: Term b)) m = + case (config, R.typeRep @a) of + ResolvedDeepType -> do + (m1, l1) <- lowerSinglePrimCached config f m + (m2, l2) <- lowerSinglePrimCached config arg m1 + let g = l1 l2 + return (addBiMapIntermediate (SomeTerm t) (toDyn g) m2, g) + _ -> translateBinaryError "tabularApply" (R.typeRep @(b =-> a)) (R.typeRep @b) (R.typeRep @a) +lowerSinglePrimImpl config t@(GeneralFunApplyTerm _ (f :: Term (b --> a)) (arg :: Term b)) m = + case (config, R.typeRep @a) of + ResolvedDeepType -> do + (m1, l1) <- lowerSinglePrimCached config f m + (m2, l2) <- lowerSinglePrimCached config arg m1 + let g = l1 l2 + return (addBiMapIntermediate (SomeTerm t) (toDyn g) m2, g) + _ -> translateBinaryError "generalApply" (R.typeRep @(b --> a)) (R.typeRep @b) (R.typeRep @a) +lowerSinglePrimImpl config t@(DivIntegerTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + (ResolvedConfig {}, IntegerType) -> lowerBinaryTerm config t arg1 arg2 SBV.sDiv m + _ -> translateBinaryError "div" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl config t@(ModIntegerTerm _ arg1 arg2) m = + case (config, R.typeRep @a) of + (ResolvedConfig {}, IntegerType) -> lowerBinaryTerm config t arg1 arg2 SBV.sMod m + _ -> translateBinaryError "mod" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) +lowerSinglePrimImpl _ _ _ = error "Should never happen" + +unsafeMkNatRepr :: Int -> NatRepr w +unsafeMkNatRepr x = NatRepr (fromInteger $ toInteger x) + +unsafeWithNonZeroKnownNat :: forall w r. Int -> ((KnownNat w, 1 <= w) => r) -> r +unsafeWithNonZeroKnownNat i r + | i <= 0 = error "Not an nonzero natural number" + | otherwise = withKnownNat @w (unsafeMkNatRepr i) $ unsafeBVIsNonZero r + where + unsafeBVIsNonZero :: ((1 <= w) => r) -> r + unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of + Refl -> r1 + +bvIsNonZeroFromGEq1 :: forall w r. (1 <= w) => ((SBV.BVIsNonZero w) => r) -> r +bvIsNonZeroFromGEq1 r1 = case unsafeAxiom :: w :~: 1 of + Refl -> r1 + +parseModel :: forall integerBitWidth. GrisetteSMTConfig integerBitWidth -> SBVI.SMTModel -> SymBiMap -> PM.Model +parseModel _ (SBVI.SMTModel _ _ assoc uifuncs) mp = foldr gouifuncs (foldr goassoc emptyModel assoc) uifuncs + where + goassoc :: (String, SBVI.CV) -> PM.Model -> PM.Model + goassoc (name, cv) m = case findStringToSymbol name mp of + Just (SomeTypedSymbol tr s) -> + insertValue s (resolveSingle tr cv) m + Nothing -> error "Bad" + resolveSingle :: R.TypeRep a -> SBVI.CV -> a + resolveSingle t (SBVI.CV SBVI.KBool (SBVI.CInteger n)) = + case R.eqTypeRep t (R.typeRep @Bool) of + Just R.HRefl -> n /= 0 + Nothing -> error "Bad type" + resolveSingle t (SBVI.CV SBVI.KUnbounded (SBVI.CInteger i)) = + case R.eqTypeRep t (R.typeRep @Integer) of + Just R.HRefl -> i + Nothing -> error "Bad type" + resolveSingle t (SBVI.CV (SBVI.KBounded _ bitWidth) (SBVI.CInteger i)) = + case R.eqTypeRep t (R.typeRep @Integer) of + Just R.HRefl -> i + _ -> case t of + R.App a (n :: R.TypeRep w) -> + case R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat) of + Just R.HRefl -> + unsafeWithNonZeroKnownNat @w bitWidth $ + case (R.eqTypeRep a (R.typeRep @IntN), R.eqTypeRep a (R.typeRep @WordN)) of + (Just R.HRefl, _) -> + fromInteger i + (_, Just R.HRefl) -> fromInteger i + _ -> error "Bad type" + _ -> error "Bad type" + _ -> error "Bad type" + resolveSingle _ _ = error "Unknown cv" + + buildConstFun :: (SupportedPrim a, SupportedPrim r) => R.TypeRep a -> R.TypeRep r -> SBVI.CV -> a =-> r + buildConstFun _ tr v = case tr of + TFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> TabularFun [] $ buildConstFun ta2' tr2' v + _ -> TabularFun [] $ resolveSingle tr v + + goutfuncResolve :: + forall a r. + (SupportedPrim a, SupportedPrim r) => + R.TypeRep a -> + R.TypeRep r -> + ([([SBVI.CV], SBVI.CV)], SBVI.CV) -> + (a =-> r) + goutfuncResolve ta1 ta2 (l, s) = + case ta2 of + TFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> + TabularFun + (second (\r -> goutfuncResolve ta2' tr2' (r, s)) <$> partition ta1 l) + (buildConstFun ta2' tr2' s) + _ -> + TabularFun + (bimap (resolveSingle ta1 . head) (resolveSingle ta2) <$> l) + (resolveSingle ta2 s) + + gougfuncResolve :: + forall a r. + (SupportedPrim a, SupportedPrim r) => + Int -> + R.TypeRep a -> + R.TypeRep r -> + ([([SBVI.CV], SBVI.CV)], SBVI.CV) -> + (a --> r) + gougfuncResolve idx ta1 ta2 (l, s) = + case ta2 of + GFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> + let sym = WithInfo (IndexedSymbol "arg" idx) FunArg + funs = second (\r -> gougfuncResolve (idx + 1) ta2' tr2' (r, s)) <$> partition ta1 l + def = gougfuncResolve (idx + 1) ta2' tr2' ([], s) + body = + foldl' + ( \acc (v, f) -> + pevalITETerm + (pevalEqvTerm (iinfosymTerm "arg" idx FunArg) (conTerm v)) + (conTerm f) + acc + ) + (conTerm def) + funs + in GeneralFun sym body + _ -> + let sym = WithInfo (IndexedSymbol "arg" idx) FunArg + vs = bimap (resolveSingle ta1 . head) (resolveSingle ta2) <$> l + def = resolveSingle ta2 s + body = + foldl' + ( \acc (v, a) -> + pevalITETerm + (pevalEqvTerm (iinfosymTerm "arg" idx FunArg) (conTerm v)) + (conTerm a) + acc + ) + (conTerm def) + vs + in GeneralFun sym body + partition :: R.TypeRep a -> [([SBVI.CV], SBVI.CV)] -> [(a, [([SBVI.CV], SBVI.CV)])] + partition t = case (R.eqTypeRep t (R.typeRep @Bool), R.eqTypeRep t (R.typeRep @Integer)) of + (Just R.HRefl, _) -> partitionWithOrd . resolveFirst t + (_, Just R.HRefl) -> partitionWithOrd . resolveFirst t + _ -> case t of + R.App bv _ -> case (R.eqTypeRep bv (R.typeRep @IntN), R.eqTypeRep bv (R.typeRep @WordN)) of + (Just R.HRefl, _) -> fmap (first IntN) . partitionWithOrd . fmap (first unIntN) . resolveFirst t + (_, Just R.HRefl) -> partitionWithOrd . resolveFirst t + _ -> error "Unknown type" + _ -> error "Unknown type" + + resolveFirst :: R.TypeRep a -> [([SBVI.CV], SBVI.CV)] -> [(a, [([SBVI.CV], SBVI.CV)])] + resolveFirst tf = fmap (\case (x : xs, v) -> (resolveSingle tf x, [(xs, v)]); _ -> error "impossible") + + partitionWithOrd :: forall a. Ord a => [(a, [([SBVI.CV], SBVI.CV)])] -> [(a, [([SBVI.CV], SBVI.CV)])] + partitionWithOrd v = go sorted + where + sorted = sortWith fst v + go (x : x1 : xs) = + if fst x == fst x1 + then go $ (fst x, snd x ++ snd x1) : xs + else x : go (x1 : xs) + go x = x + + gouifuncs :: (String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV))) -> PM.Model -> PM.Model + gouifuncs (name, (SBVI.SBVType _, l)) m = case findStringToSymbol name mp of + Just (SomeTypedSymbol tr s) -> withSymbolSupported s $ case tr of + t@(TFunType a r) -> R.withTypeable t $ insertValue s (goutfuncResolve a r l) m + t@(GFunType a r) -> R.withTypeable t $ insertValue s (gougfuncResolve 0 a r l) m + _ -> error "Bad" + Nothing -> error "Bad" + +-- helpers + +data BVTypeContainer bv k where + BVTypeContainer :: (SBV.BVIsNonZero n, KnownNat n, 1 <= n, k ~ bv n) => Proxy n -> BVTypeContainer bv k + +signedBVTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (BVTypeContainer IntN t) +signedBVTypeView t = case t of + R.App s (n :: R.TypeRep w) -> + case (R.eqTypeRep s (R.typeRep @IntN), R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat)) of + (Just R.HRefl, Just R.HRefl) -> + Just $ unsafeBVIsNonZero @w $ withPrim (Proxy @t) (BVTypeContainer Proxy) + _ -> Nothing + _ -> Nothing + where + unsafeBVIsNonZero :: forall w r. ((SBV.BVIsNonZero w) => r) -> r + unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of + Refl -> r1 + +pattern SignedBVType :: + forall t. + (SupportedPrim t) => + forall (n :: Nat). + (t ~~ IntN n, KnownNat n, 1 <= n, SBV.BVIsNonZero n) => + Proxy n -> + R.TypeRep t +pattern SignedBVType p <- (signedBVTypeView @t -> Just (BVTypeContainer p)) + +unsignedBVTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (BVTypeContainer WordN t) +unsignedBVTypeView t = case t of + R.App s (n :: R.TypeRep w) -> + case (R.eqTypeRep s (R.typeRep @WordN), R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat)) of + (Just R.HRefl, Just R.HRefl) -> + Just $ unsafeBVIsNonZero @w $ withPrim (Proxy @t) (BVTypeContainer Proxy) + _ -> Nothing + _ -> Nothing + where + unsafeBVIsNonZero :: forall w r. ((SBV.BVIsNonZero w) => r) -> r + unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of + Refl -> r1 + +pattern UnsignedBVType :: + forall t. + (SupportedPrim t) => + forall (n :: Nat). + (t ~~ WordN n, KnownNat n, 1 <= n, SBV.BVIsNonZero n) => + Proxy n -> + R.TypeRep t +pattern UnsignedBVType p <- (unsignedBVTypeView @t -> Just (BVTypeContainer p)) + +data TFunTypeContainer :: forall k. k -> Type where + TFunTypeContainer :: (SupportedPrim a, SupportedPrim b) => R.TypeRep a -> R.TypeRep b -> TFunTypeContainer (a =-> b) + +tFunTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (TFunTypeContainer t) +tFunTypeView t = case t of + R.App (R.App arr (ta2' :: R.TypeRep a2)) (tr2' :: R.TypeRep r2) -> + case R.eqTypeRep arr (R.typeRep @(=->)) of + Just R.HRefl -> Just $ withPrim (Proxy @t) $ TFunTypeContainer ta2' tr2' + Nothing -> Nothing + _ -> Nothing + +pattern TFunType :: + forall t. + (SupportedPrim t) => + forall (a :: Type) (b :: Type). + (t ~~ (a =-> b), SupportedPrim a, SupportedPrim b) => + R.TypeRep a -> + R.TypeRep b -> + R.TypeRep t +pattern TFunType a b <- + (tFunTypeView -> Just (TFunTypeContainer a b)) + where + TFunType a b = R.App (R.App (R.typeRep @(=->)) a) b + +pattern TFun3Type :: + forall t. + (SupportedPrim t) => + forall (a :: Type) (b :: Type) (c :: Type). + (t ~~ (a =-> b =-> c), SupportedPrim a, SupportedPrim b, SupportedPrim c) => + R.TypeRep a -> + R.TypeRep b -> + R.TypeRep c -> + R.TypeRep t +pattern TFun3Type a b c = TFunType a (TFunType b c) + +data GFunTypeContainer :: forall k. k -> Type where + GFunTypeContainer :: (SupportedPrim a, SupportedPrim b) => R.TypeRep a -> R.TypeRep b -> GFunTypeContainer (a --> b) + +gFunTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (GFunTypeContainer t) +gFunTypeView t = case t of + R.App (R.App arr (ta2' :: R.TypeRep a2)) (tr2' :: R.TypeRep r2) -> + case R.eqTypeRep arr (R.typeRep @(-->)) of + Just R.HRefl -> Just $ withPrim (Proxy @t) $ GFunTypeContainer ta2' tr2' + Nothing -> Nothing + _ -> Nothing + +pattern GFunType :: + forall t. + (SupportedPrim t) => + forall (a :: Type) (b :: Type). + (t ~~ (a --> b), SupportedPrim a, SupportedPrim b) => + R.TypeRep a -> + R.TypeRep b -> + R.TypeRep t +pattern GFunType a b <- + (gFunTypeView -> Just (GFunTypeContainer a b)) + where + GFunType a b = R.App (R.App (R.typeRep @(-->)) a) b + +pattern GFun3Type :: + forall t. + (SupportedPrim t) => + forall (a :: Type) (b :: Type) (c :: Type). + (t ~~ (a --> b --> c), SupportedPrim a, SupportedPrim b, SupportedPrim c) => + R.TypeRep a -> + R.TypeRep b -> + R.TypeRep c -> + R.TypeRep t +pattern GFun3Type a b c = GFunType a (GFunType b c) + +pattern BoolType :: + forall t. + () => + (t ~~ Bool) => + R.TypeRep t +pattern BoolType <- (R.eqTypeRep (R.typeRep @Bool) -> Just R.HRefl) + +pattern IntegerType :: + forall t. + () => + (t ~~ Integer) => + R.TypeRep t +pattern IntegerType <- (R.eqTypeRep (R.typeRep @Integer) -> Just R.HRefl) + +type ConfigConstraint integerBitWidth s = + ( SBV.SBV s ~ TermTy integerBitWidth Integer, + SBV.SymVal s, + SBV.HasKind s, + Typeable s, + Num (SBV.SBV s), + Num s, + SBV.OrdSymbolic (SBV.SBV s), + Ord s, + SBV.SDivisible (SBV.SBV s), + SBV.OrdSymbolic (SBV.SBV s), + SBV.Mergeable (SBV.SBV s) + ) + +data DictConfig integerBitWidth where + DictConfig :: + forall s integerBitWidth. + (ConfigConstraint integerBitWidth s) => + SBV.SMTConfig -> + DictConfig integerBitWidth + +resolveConfigView :: + forall integerBitWidth. + GrisetteSMTConfig integerBitWidth -> + DictConfig integerBitWidth +resolveConfigView config = case config of + UnboundedReasoning c -> DictConfig c + BoundedReasoning c -> DictConfig c + +pattern ResolvedConfig :: + forall integerBitWidth. + () => + forall s. + ConfigConstraint integerBitWidth s => + SBV.SMTConfig -> + GrisetteSMTConfig integerBitWidth +pattern ResolvedConfig c <- (resolveConfigView -> DictConfig c) + +type SimpleTypeConstraint integerBitWidth s s' = + ( SBV.SBV s' ~ TermTy integerBitWidth s, + SBV.SymVal s', + SBV.HasKind s', + Typeable s', + SBV.OrdSymbolic (SBV.SBV s'), + SBV.Mergeable (SBV.SBV s') + ) + +type TypeResolver dictType = + forall integerBitWidth s. + (SupportedPrim s) => + (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -> + Maybe (dictType integerBitWidth s) + +-- has to declare this because GHC does not support impredicative polymorphism +data DictSimpleType integerBitWidth s where + DictSimpleType :: + forall integerBitWidth s s'. + (SimpleTypeConstraint integerBitWidth s s') => + DictSimpleType integerBitWidth s + +resolveSimpleTypeView :: TypeResolver DictSimpleType +resolveSimpleTypeView (ResolvedConfig {}, s) = case s of + BoolType -> Just DictSimpleType + IntegerType -> Just DictSimpleType + SignedBVType _ -> Just DictSimpleType + UnsignedBVType _ -> Just DictSimpleType + _ -> Nothing +resolveSimpleTypeView _ = error "Should never happen, make compiler happy" + +pattern ResolvedSimpleType :: + forall integerBitWidth s. + (SupportedPrim s) => + forall s'. + SimpleTypeConstraint integerBitWidth s s' => + (GrisetteSMTConfig integerBitWidth, R.TypeRep s) +pattern ResolvedSimpleType <- (resolveSimpleTypeView -> Just DictSimpleType) + +type DeepTypeConstraint integerBitWidth s s' = + ( s' ~ TermTy integerBitWidth s, + Typeable s', + SBV.Mergeable s' + ) + +data DictDeepType integerBitWidth s where + DictDeepType :: + forall integerBitWidth s s'. + (DeepTypeConstraint integerBitWidth s s') => + DictDeepType integerBitWidth s + +resolveDeepTypeView :: TypeResolver DictDeepType +resolveDeepTypeView r = case r of + ResolvedSimpleType -> Just DictDeepType + (config, TFunType (ta :: R.TypeRep a) (tb :: R.TypeRep b)) -> + case (resolveDeepTypeView (config, ta), resolveDeepTypeView (config, tb)) of + (Just DictDeepType, Just DictDeepType) -> Just DictDeepType + _ -> Nothing + (config, GFunType (ta :: R.TypeRep a) (tb :: R.TypeRep b)) -> + case (resolveDeepTypeView (config, ta), resolveDeepTypeView (config, tb)) of + (Just DictDeepType, Just DictDeepType) -> Just DictDeepType + _ -> Nothing + _ -> Nothing + +pattern ResolvedDeepType :: + forall integerBitWidth s. + (SupportedPrim s) => + forall s'. + DeepTypeConstraint integerBitWidth s s' => + (GrisetteSMTConfig integerBitWidth, R.TypeRep s) +pattern ResolvedDeepType <- (resolveDeepTypeView -> Just DictDeepType) + +type NumTypeConstraint integerBitWidth s s' = + ( SimpleTypeConstraint integerBitWidth s s', + Num (SBV.SBV s'), + Num s', + Num s + ) + +data DictNumType integerBitWidth s where + DictNumType :: + forall integerBitWidth s s'. + (NumTypeConstraint integerBitWidth s s') => + DictNumType integerBitWidth s + +resolveNumTypeView :: TypeResolver DictNumType +resolveNumTypeView (ResolvedConfig {}, s) = case s of + IntegerType -> Just DictNumType + SignedBVType _ -> Just DictNumType + UnsignedBVType _ -> Just DictNumType + _ -> Nothing +resolveNumTypeView _ = error "Should never happen, make compiler happy" + +pattern ResolvedNumType :: + forall integerBitWidth s. + (SupportedPrim s) => + forall s'. + NumTypeConstraint integerBitWidth s s' => + (GrisetteSMTConfig integerBitWidth, R.TypeRep s) +pattern ResolvedNumType <- (resolveNumTypeView -> Just DictNumType) + +type NumOrdTypeConstraint integerBitWidth s s' = + ( NumTypeConstraint integerBitWidth s s', + SBV.OrdSymbolic (SBV.SBV s'), + Ord s', + Ord s + ) + +data DictNumOrdType integerBitWidth s where + DictNumOrdType :: + forall integerBitWidth s s'. + (NumOrdTypeConstraint integerBitWidth s s') => + DictNumOrdType integerBitWidth s + +resolveNumOrdTypeView :: TypeResolver DictNumOrdType +resolveNumOrdTypeView (ResolvedConfig {}, s) = case s of + IntegerType -> Just DictNumOrdType + SignedBVType _ -> Just DictNumOrdType + UnsignedBVType _ -> Just DictNumOrdType + _ -> Nothing +resolveNumOrdTypeView _ = error "Should never happen, make compiler happy" + +pattern ResolvedNumOrdType :: + forall integerBitWidth s. + (SupportedPrim s) => + forall s'. + NumOrdTypeConstraint integerBitWidth s s' => + (GrisetteSMTConfig integerBitWidth, R.TypeRep s) +pattern ResolvedNumOrdType <- (resolveNumOrdTypeView -> Just DictNumOrdType) + +type BitsTypeConstraint integerBitWidth s s' = + ( SimpleTypeConstraint integerBitWidth s s', + Bits (SBV.SBV s'), + Bits s', + Bits s + ) + +data DictBitsType integerBitWidth s where + DictBitsType :: + forall integerBitWidth s s'. + (BitsTypeConstraint integerBitWidth s s') => + DictBitsType integerBitWidth s + +resolveBitsTypeView :: TypeResolver DictBitsType +resolveBitsTypeView (ResolvedConfig {}, s) = case s of + SignedBVType _ -> Just DictBitsType + UnsignedBVType _ -> Just DictBitsType + _ -> Nothing +resolveBitsTypeView _ = error "Should never happen, make compiler happy" + +pattern ResolvedBitsType :: + forall integerBitWidth s. + (SupportedPrim s) => + forall s'. + BitsTypeConstraint integerBitWidth s s' => + (GrisetteSMTConfig integerBitWidth, R.TypeRep s) +pattern ResolvedBitsType <- (resolveBitsTypeView -> Just DictBitsType) diff --git a/src/Grisette/Backend/SBV/Data/SMT/Solving.hs b/src/Grisette/Backend/SBV/Data/SMT/Solving.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Backend/SBV/Data/SMT/Solving.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Backend.SBV.Data.SMT.Solving +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Backend.SBV.Data.SMT.Solving + ( GrisetteSMTConfig (..), + sbvConfig, + TermTy, + ) +where + +import Control.DeepSeq +import Control.Monad.Except +import qualified Data.HashSet as S +import Data.Hashable +import Data.Kind +import Data.List (partition) +import Data.Maybe +import qualified Data.SBV as SBV +import Data.SBV.Control (Query) +import qualified Data.SBV.Control as SBVC +import GHC.TypeNats +import Grisette.Backend.SBV.Data.SMT.Lowering +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.CEGISSolver +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.ModelOps +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.Solver +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.Model as PM +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.SymPrim +import Grisette.IR.SymPrim.Data.TabularFun +import Language.Haskell.TH.Syntax (Lift) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.Backend.SBV + +type Aux :: Bool -> Nat -> Type +type family Aux o n where + Aux 'True n = SBV.SInteger + Aux 'False n = SBV.SInt n + +type IsZero :: Nat -> Bool +type family IsZero n where + IsZero 0 = 'True + IsZero _ = 'False + +type TermTy :: Nat -> Type -> Type +type family TermTy bitWidth b where + TermTy _ Bool = SBV.SBool + TermTy n Integer = Aux (IsZero n) n + TermTy n (IntN x) = SBV.SBV (SBV.IntN x) + TermTy n (WordN x) = SBV.SBV (SBV.WordN x) + TermTy n (a =-> b) = TermTy n a -> TermTy n b + TermTy n (a --> b) = TermTy n a -> TermTy n b + TermTy _ v = v + +-- | Solver configuration for the Grisette SBV backend. +-- A Grisette solver configuration consists of a SBV solver configuration and +-- the reasoning precision. +-- +-- Integers can be unbounded (mathematical integer) or bounded (machine +-- integer/bit vector). The two types of integers have their own use cases, +-- and should be used to model different systems. +-- However, the solvers are known to have bad performance on some unbounded +-- integer operations, for example, when reason about non-linear integer +-- algebraic (e.g., multiplication or division), +-- the solver may not be able to get a result in a reasonable time. +-- In contrast, reasoning about bounded integers is usually more efficient. +-- +-- To bridge the performance gap between the two types of integers, Grisette +-- allows to model the system with unbounded integers, and evaluate them with +-- infinite precision during the symbolic evaluation, but when solving the +-- queries, they are translated to bit vectors for better performance. +-- +-- For example, the Grisette term @5 * "a" :: SymInteger@ should be translated +-- to the following SMT with the unbounded reasoning configuration (the term +-- is @t1@): +-- +-- > (declare-fun a () Int) ; declare symbolic constant a +-- > (define-fun c1 () Int 5) ; define the concrete value 5 +-- > (define-fun t1 () Int (* c1 a)) ; define the term +-- +-- While with reasoning precision 4, it would be translated to the following +-- SMT (the term is @t1@): +-- +-- > ; declare symbolic constant a, the type is a bit vector with bit width 4 +-- > (declare-fun a () (_ BitVec 4)) +-- > ; define the concrete value 1, translated to the bit vector #x1 +-- > (define-fun c1 () (_ BitVec 4) #x5) +-- > ; define the term, using bit vector addition rather than integer addition +-- > (define-fun t1 () (_ BitVec 4) (bvmul c1 a)) +-- +-- This bounded translation can usually be solved faster than the unbounded +-- one, and should work well when no overflow is possible, in which case the +-- performance can be improved with almost no cost. +-- +-- We must note that the bounded translation is an approximation and is __/not/__ +-- __/sound/__. As the approximation happens only during the final translation, +-- the symbolic evaluation may aggressively optimize the term based on the +-- properties of mathematical integer arithmetic. This may cause the solver yield +-- results that is incorrect under both unbounded or bounded semantics. +-- +-- The following is an example that is correct under bounded semantics, while is +-- incorrect under the unbounded semantics: +-- +-- >>> :set -XTypeApplications -XOverloadedStrings -XDataKinds +-- >>> let a = "a" :: SymInteger +-- >>> solve (UnboundedReasoning z3) $ a >~ 7 &&~ a <~ 9 +-- Right (Model {a -> 8 :: Integer}) +-- >>> solve (BoundedReasoning @4 z3) $ a >~ 7 &&~ a <~ 9 +-- Left Unsat +-- +-- This should be avoided by setting an large enough reasoning precision to prevent +-- overflows. +data GrisetteSMTConfig (integerBitWidth :: Nat) where + UnboundedReasoning :: SBV.SMTConfig -> GrisetteSMTConfig 0 + BoundedReasoning :: + (KnownNat integerBitWidth, IsZero integerBitWidth ~ 'False, SBV.BVIsNonZero integerBitWidth) => + SBV.SMTConfig -> + GrisetteSMTConfig integerBitWidth + +-- | Extract the SBV solver configuration from the Grisette solver configuration. +sbvConfig :: forall integerBitWidth. GrisetteSMTConfig integerBitWidth -> SBV.SMTConfig +sbvConfig (UnboundedReasoning config) = config +sbvConfig (BoundedReasoning config) = config + +solveTermWith :: + forall integerBitWidth. + GrisetteSMTConfig integerBitWidth -> + Term Bool -> + IO (SymBiMap, Either SBVC.CheckSatResult PM.Model) +solveTermWith config term = SBV.runSMTWith (sbvConfig config) $ do + (m, a) <- lowerSinglePrim config term + SBVC.query $ do + SBV.constrain a + r <- SBVC.checkSat + case r of + SBVC.Sat -> do + md <- SBVC.getModel + return (m, Right $ parseModel config md m) + _ -> return (m, Left r) + +instance Solver (GrisetteSMTConfig n) SBVC.CheckSatResult where + solve config (Sym t) = snd <$> solveTermWith config t + solveMulti config n s@(Sym t) + | n > 0 = SBV.runSMTWith (sbvConfig config) $ do + (newm, a) <- lowerSinglePrim config t + SBVC.query $ do + SBV.constrain a + r <- SBVC.checkSat + case r of + SBVC.Sat -> do + md <- SBVC.getModel + let model = parseModel config md newm + remainingModels n model newm + _ -> return [] + | otherwise = return [] + where + allSymbols = extractSymbolics s :: SymbolSet + next :: PM.Model -> SymBiMap -> Query (SymBiMap, Either SBVC.CheckSatResult PM.Model) + next md origm = do + let newtm = + S.foldl' + (\acc (SomeTypedSymbol _ v) -> pevalOrTerm acc (pevalNotTerm (fromJust $ equation v md))) + (conTerm False) + (unSymbolSet allSymbols) + let (lowered, newm) = lowerSinglePrim' config newtm origm + SBV.constrain lowered + r <- SBVC.checkSat + case r of + SBVC.Sat -> do + md1 <- SBVC.getModel + let model = parseModel config md1 newm + return (newm, Right model) + _ -> return (newm, Left r) + remainingModels :: Int -> PM.Model -> SymBiMap -> Query [PM.Model] + remainingModels n1 md origm + | n1 > 1 = do + (newm, r) <- next md origm + case r of + Left _ -> return [md] + Right mo -> do + rmmd <- remainingModels (n1 - 1) mo newm + return $ md : rmmd + | otherwise = return [md] + solveAll = undefined + +instance CEGISSolver (GrisetteSMTConfig n) SBVC.CheckSatResult where + cegisMultiInputs :: + forall inputs spec. + (ExtractSymbolics inputs, EvaluateSym inputs) => + GrisetteSMTConfig n -> + [inputs] -> + (inputs -> CEGISCondition) -> + IO (Either SBVC.CheckSatResult ([inputs], PM.Model)) + cegisMultiInputs config inputs func = + go1 (cexesAssertFun conInputs) conInputs (error "Should have at least one gen") [] (con True) (con True) symInputs + where + (conInputs, symInputs) = partition (isEmptySet . extractSymbolics) inputs + go1 cexFormula cexes previousModel inputs pre post remainingSymInputs = do + case remainingSymInputs of + [] -> return $ Right (cexes, previousModel) + newInput : vs -> do + let CEGISCondition nextPre nextPost = func newInput + let finalPre = pre &&~ nextPre + let finalPost = post &&~ nextPost + r <- go cexFormula newInput (newInput : inputs) finalPre finalPost + case r of + Left failure -> return $ Left failure + Right (newCexes, mo) -> do + go1 + (cexFormula &&~ cexesAssertFun newCexes) + (cexes ++ newCexes) + mo + (newInput : inputs) + finalPre + finalPost + vs + cexAssertFun input = + let CEGISCondition pre post = func input in pre &&~ post + cexesAssertFun :: [inputs] -> SymBool + cexesAssertFun = foldl (\acc x -> acc &&~ cexAssertFun x) (con True) + go :: + SymBool -> + inputs -> + [inputs] -> + SymBool -> + SymBool -> + IO (Either SBVC.CheckSatResult ([inputs], PM.Model)) + go cexFormula inputs allInputs pre post = + SBV.runSMTWith (sbvConfig config) $ do + let Sym t = phi &&~ cexFormula + (newm, a) <- lowerSinglePrim config t + SBVC.query $ + snd <$> do + SBV.constrain a + r <- SBVC.checkSat + mr <- case r of + SBVC.Sat -> do + md <- SBVC.getModel + return $ Right $ parseModel config md newm + _ -> return $ Left r + loop ((forallSymbols `exceptFor`) <$> mr) [] newm + where + forallSymbols :: SymbolSet + forallSymbols = extractSymbolics allInputs + phi = pre &&~ post + negphi = pre &&~ nots post + check :: Model -> IO (Either SBVC.CheckSatResult (inputs, PM.Model)) + check candidate = do + let evaluated = evaluateSym False candidate negphi + r <- solve config evaluated + return $ do + m <- r + let newm = exact forallSymbols m + return (evaluateSym False newm inputs, newm) + guess :: Model -> SymBiMap -> Query (SymBiMap, Either SBVC.CheckSatResult PM.Model) + guess candidate origm = do + let Sym evaluated = evaluateSym False candidate phi + let (lowered, newm) = lowerSinglePrim' config evaluated origm + SBV.constrain lowered + r <- SBVC.checkSat + case r of + SBVC.Sat -> do + md <- SBVC.getModel + let model = parseModel config md newm + return (newm, Right $ exceptFor forallSymbols model) + _ -> return (newm, Left r) + loop :: + Either SBVC.CheckSatResult PM.Model -> + [inputs] -> + SymBiMap -> + Query (SymBiMap, Either SBVC.CheckSatResult ([inputs], PM.Model)) + loop (Right mo) cexs origm = do + r <- liftIO $ check mo + case r of + Left SBVC.Unsat -> return (origm, Right (cexs, mo)) + Left v -> return (origm, Left v) + Right (cex, cexm) -> do + (newm, res) <- guess cexm origm + loop res (cex : cexs) newm + loop (Left v) _ origm = return (origm, Left v) + +newtype CegisInternal = CegisInternal Int + deriving (Eq, Show, Ord, Lift) + deriving newtype (Hashable, NFData) diff --git a/src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot b/src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Backend.SBV.Data.SMT.Solving + ( GrisetteSMTConfig (..), + TermTy, + ) +where + +import Data.Kind +import qualified Data.SBV as SBV +import GHC.TypeNats +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.TabularFun + +type Aux :: Bool -> Nat -> Type +type family Aux o n where + Aux 'True n = SBV.SInteger + Aux 'False n = SBV.SInt n + +type IsZero :: Nat -> Bool +type family IsZero n where + IsZero 0 = 'True + IsZero _ = 'False + +type TermTy :: Nat -> Type -> Type +type family TermTy bitWidth b where + TermTy _ Bool = SBV.SBool + TermTy n Integer = Aux (IsZero n) n + TermTy n (IntN x) = SBV.SBV (SBV.IntN x) + TermTy n (WordN x) = SBV.SBV (SBV.WordN x) + TermTy n (a =-> b) = TermTy n a -> TermTy n b + TermTy n (a --> b) = TermTy n a -> TermTy n b + TermTy _ v = v + +data GrisetteSMTConfig (integerBitWidth :: Nat) where + UnboundedReasoning :: SBV.SMTConfig -> GrisetteSMTConfig 0 + BoundedReasoning :: + (KnownNat integerBitWidth, IsZero integerBitWidth ~ 'False, SBV.BVIsNonZero integerBitWidth) => + SBV.SMTConfig -> + GrisetteSMTConfig integerBitWidth diff --git a/src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs b/src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Grisette.Backend.SBV.Data.SMT.SymBiMap +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Backend.SBV.Data.SMT.SymBiMap + ( SymBiMap (..), + emptySymBiMap, + sizeBiMap, + addBiMap, + addBiMapIntermediate, + findStringToSymbol, + lookupTerm, + ) +where + +import Data.Dynamic +import qualified Data.HashMap.Strict as M +import GHC.Stack +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + +data SymBiMap = SymBiMap + { biMapToSBV :: M.HashMap SomeTerm Dynamic, + biMapFromSBV :: M.HashMap String SomeTypedSymbol + } + deriving (Show) + +emptySymBiMap :: SymBiMap +emptySymBiMap = SymBiMap M.empty M.empty + +sizeBiMap :: SymBiMap -> Int +sizeBiMap = M.size . biMapToSBV + +addBiMap :: HasCallStack => SomeTerm -> Dynamic -> String -> SomeTypedSymbol -> SymBiMap -> SymBiMap +addBiMap s d n sb (SymBiMap t f) = SymBiMap (M.insert s d t) (M.insert n sb f) + +addBiMapIntermediate :: HasCallStack => SomeTerm -> Dynamic -> SymBiMap -> SymBiMap +addBiMapIntermediate s d (SymBiMap t f) = SymBiMap (M.insert s d t) f + +findStringToSymbol :: String -> SymBiMap -> Maybe SomeTypedSymbol +findStringToSymbol s (SymBiMap _ f) = M.lookup s f + +lookupTerm :: HasCallStack => SomeTerm -> SymBiMap -> Maybe Dynamic +lookupTerm t m = M.lookup t (biMapToSBV m) diff --git a/src/Grisette/Core.hs b/src/Grisette/Core.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core.hs @@ -0,0 +1,1045 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core + ( -- * Note for the examples + + -- + + -- | The examples may assume a [z3](https://github.com/Z3Prover/z3) solver available in @PATH@. + + -- * Symbolic values + + -- | Grisette is a tool for performing symbolic evaluation on programs. + -- Symbolic evaluation is a technique that allows us to analyze all + -- possible runs of a program by representing inputs (or the program + -- itself) as symbolic values and evaluating the program to produce + -- symbolic constraints over these values. + -- These constraints can then be used to find concrete assignments to the + -- symbolic values that meet certain criteria, such as triggering a bug in + -- a verification task or satisfying a specification in a synthesis task. + -- + -- One of the challenges of symbolic evaluation is the well-known path + -- explosion problem, which occurs when traditions symbolic evaluation + -- techniques evaluate and reason about the possible paths one-by-one. + -- This can lead to exponential growth in the number of paths that need to + -- be analyzed, making the process impractical for many tasks. + -- To address this issue, Grisette uses a technique called "path merging". + -- In path merging, symbolic values are merged together in order to reduce + -- the number of paths that need to be explored simultaneously. This can + -- significantly improve the performance of symbolic evaluation, especially + -- for tasks such as program synthesis that are prone to the path explosion + -- problem. + -- + -- In Grisette, we make a distinction between two kinds of symbolic values: + -- __/solvable types/__ and __/unsolvable types/__. These two types of + -- values are merged differently. + -- + -- __/Solvable types/__ are types that are directly supported by the + -- underlying solver and are represented as symbolic formulas. Examples + -- include symbolic Booleans, integers and bit vectors. The values of + -- solvable types can be __/fully/__ merged into a single value, which + -- can significantly reduce the number of paths that need to be explored. + -- + -- For example, there are three symbolic Booleans @a@, @b@ and @c@, in the + -- following code, and a symbolic Boolean @x@ is defined to be the result of + -- a conditional expression: + -- + -- > x = if a then b else c -- pseudo code, not real Grisette code + -- + -- The result would be a single symbolic Boolean formula: + -- + -- > -- result: x is (ite a b c) + -- + -- If we further add 1 to @x@, we will not have to split to two paths, + -- but we can directly construct a formula with the merged state: + -- + -- > x + 1 + -- > -- result (+ 1 (ite a b c)) + -- + -- __/Unsolvable types/__, on the other hand, are types that are not + -- directly supported by the solver and cannot be fully merged into a + -- single formula. Examples include lists, algebraic data types, and + -- concrete Haskell integer types. To symbolically evaluate values in + -- unsolvable types, Grisette provides a symbolic union container, which is + -- a set of values guarded by their path conditions. + -- The values of unsolvable types are __/partially/__ merged in a symbolic + -- union, which is essentially an if-then-else tree. + -- + -- For example, assume that the lists have the type @[SymBool]@. + -- In the following example, the result shows that @[b]@ and @[c]@ can be + -- merged together in the same symbolic union because they have the same + -- length: + -- + -- > x = if a then [b] else [c] -- pseudo code, not real Grisette code + -- > -- result: Single [(ite a b c)] + -- + -- The second example shows that @[b]@ and @[c,d]@ cannot be merged + -- together because they have different lengths: + -- + -- > if a then [b] else [c, d] -- pseudo code, not real Grisette code + -- > -- result: If a (Single [b]) (Single [c,d]) + -- + -- The following example is more complicated. To make the merging + -- efficient, Grisette would maintain a representation invariant of the + -- symbolic unions. In this case, the lists with length 1 should be placed + -- at the then branch, and the lists with length 2 should be placed at the + -- else branch. + -- + -- > if a1 then [b] else if a2 then [c, d] else [f] -- pseudo code, not real Grisette code + -- > -- result: If (|| a1 (! a2)) (Single [(ite a1 b f)]) (Single [c,d]) + -- + -- When we further operate on this partially merged values, + -- we will need to split into multiple paths. For example, when we apply 'head' + -- onto the last result, we will distribute 'head' among the branches: + -- + -- > head (if a1 then [b] else if a2 then [c, d] else [f]) -- pseudo code, not real Grisette code + -- > -- intermediate result: If (|| a1 (! a2)) (Single (head [(ite a1 b f)])) (Single (head [c,d])) + -- > -- intermediate result: If (|| a1 (! a2)) (Single (ite a1 b f)) (Single c) + -- + -- Then the result would be further merged into a single value: + -- + -- > -- final result: Single (ite (|| a1 (! a2)) (ite a1 b f) c) + -- + -- Generally, merging the possible branches in a symbolic union can reduce + -- the number of paths to be explored in the future, but can make the path + -- conditions larger and harder to solve. To have a good balance between + -- this, Grisette has built a hierarchical merging algorithm, which is + -- configurable via 'MergingStrategy'. For algebraic data types, we have + -- prebuilt merging strategies via the derivation of the 'Mergeable' type + -- class. You only need to know the details of the merging algorithm if you + -- are going to work with non-algebraic data types. + + -- ** Solvable types + + -- | A solvable type is a type that can be represented as a formula and is + -- directly supported by the underlying constraint solvers. + -- Grisette + -- currently provides an implementation for the following solvable types: + -- + -- * @SymBool@ or @Sym Bool@ (symbolic Booleans) + -- * @SymInteger@ or @Sym Integer@ (symbolic unbounded integers) + -- * @SymIntN n@ or @Sym (IntN n)@ (symbolic signed bit vectors of length @n@) + -- * @SymWordN n@ or @Sym (WordN n)@ (symbolic unsigned bit vectors of length @n@) + -- + -- Values of a solvable type can consist of concrete values, symbolic + -- constants (placeholders for concrete values that can be assigned by a + -- solver to satisfy a formula), and complex symbolic formulas with + -- symbolic operations. The `Solvable` type class provides a way to + -- construct concrete values and symbolic constants. + -- + -- __Examples:__ + -- + -- >>> import Grisette + -- >>> con True :: SymBool -- a concrete value + -- true + -- >>> ssym "a" :: SymBool -- a symbolic constant + -- a + -- + -- With the @OverloadedStrings@ GHC extension enabled, symbolic constants + -- can also be constructed from strings. + -- + -- >>> :set -XOverloadedStrings + -- >>> "a" :: SymBool + -- a + -- + -- Symbolic operations are provided through a set of type classes, + -- such as 'SEq', 'SOrd', and 'Num'. Please check out the documentation for + -- more details. + -- + -- __Examples:__ + -- + -- >>> let a = "a" :: SymInteger + -- >>> let b = "b" :: SymInteger + -- >>> a ==~ b + -- (= a b) + + -- *** Creation of solvable type values + Solvable (..), + pattern Con, + slocsym, + ilocsym, + + -- *** Symbolic operators + + -- | #symop# + LogicalOp (..), + ITEOp (..), + SEq (..), + SymBoolOp, + SOrd (..), + BVConcat (..), + BVExtend (..), + BVSelect (..), + bvextract, + SignedDivMod (..), + UnsignedDivMod (..), + SignedQuotRem (..), + SymIntegerOp, + Function (..), + + -- ** Unsolvable types + + -- | There are types that cannot be directly represented as SMT formulas + -- and therefore not supported by the SMT solvers. These types are referred + -- to as __/unsolvable types/__. + -- To symbolically evaluate such types, we represent them with + -- __/symbolic unions/__. + -- A symbolic union is a set of multiple values from different execution + -- paths, each guarded with a corresponding path condition. + -- The value of a union can be determined by an SMT solver based on the + -- truth value of the path conditions. + -- + -- In Grisette, the symbolic union type is 'UnionM'. + -- Two constructs are useful in constructing symbolic union values: 'mrgIf' + -- and 'mrgSingle'. + -- 'mrgSingle' unconditionally wraps a value in a symbolic union container, + -- while 'mrgIf' models branching control flow semantics with symbolic + -- conditions. + -- Here are some examples of using 'mrgSingle' and 'mrgIf': + -- + -- >>> mrgSingle ["a"] :: UnionM [SymInteger] + -- {[a]} + -- >>> mrgIf "a" (mrgSingle ["b"]) (mrgSingle ["c", "d"]) :: UnionM [SymInteger] + -- {If a [b] [c,d]} + -- + -- 'UnionM' is a monad, and its bind operation is similar to tree + -- substitution. + -- This means you can then use monadic constructs to model sequential programs. + -- For example, the following pseudo code can be + -- modeled in Grisette with the combinators provided by Grisette, and the do-notation: + -- + -- > x = if a then [b] else [b,c] -- pseudo code, not Grisette code + -- > y = if d then [e] else [e,f] + -- > return (x ++ y :: [SymInteger]) + -- + -- >>> :{ + -- ret :: UnionM [SymInteger] + -- ret = do x <- mrgIf "a" (single ["b"]) (single ["b","c"]) + -- y <- mrgIf "d" (single ["e"]) (single ["e","f"]) + -- mrgReturn $ x ++ y -- we will explain mrgReturn later + -- :} + -- + -- When this code is evaluated, the result would be as follows: + -- + -- >>> ret + -- {If (&& a d) [b,e] (If (|| a d) [b,(ite a e c),(ite a f e)] [b,c,e,f])} + -- + -- In the result, we can see that the results are reorganized and the two + -- lists with the same length are merged together. + -- This is important for scaling symbolic evaluation to real-world + -- problems. + -- + -- The 'mrgReturn' function is crucial for ensuring that the results + -- are merged. It resolves the 'Mergeable' constraint, and retrieves a + -- merging strategy for the contained type from the constraint. + -- The merging strategy is then cached in the 'UnionMBase' container to + -- help merge the result of the entire do-block. + -- This is necessary due to + -- [the constrained-monad problem](https://dl.acm.org/doi/10.1145/2500365.2500602), + -- as the 'return' function from the 'Monad' type class cannot resolve + -- extra constraints. + -- Our solution to this problem with merging strategy caching is inspired + -- by the knowledge propagation technique introduced in the + -- [blog post](https://okmij.org/ftp/Haskell/set-monad.html#PE) by Oleg Kiselyov. + -- + -- In addition to 'mrgReturn', + -- Grisette provides many combinators with the @mrg@ prefix. + -- You should use these combinators and always have the result cache the merging strategy. + -- Consider the following code: + -- + -- >>> return 1 :: UnionM Integer + -- <1> + -- >>> mrgReturn 1 :: UnionM Integer + -- {1} + -- >>> mrgIf "a" (return 1) (return 2) :: UnionM Integer + -- {If a 1 2} + -- + -- In the first example, using 'return' instead of 'mrgReturn' results in a + -- 'UAny' container (printed as @<@@...@@>@), which means that no merging + -- strategy is cached. + -- In the second and third example, using 'mrgReturn' or 'mrgIf' results in + -- a 'UMrg' container (printed as @{...}@), + -- which means that the merging strategy is cached. + -- + -- When working with 'UnionM', it is important to always use the @mrg@ prefixed + -- combinators to ensure that the merging strategy is properly cached. + -- This will enable Grisette to properly merge the results of the entire do-block + -- and scale symbolic evaluation to real-world problems. + -- Those functions that merges the results can also further propagate the + -- cached merging strategy, note that the result is merged: + -- + -- >>> f x y = mrgIf "f" (return x) (return y) + -- >>> do; a <- mrgIf "a" (return 1) (return 2); f a (a + 1) :: UnionM Integer + -- {If (&& a f) 1 (If (|| a f) 2 3)} + -- + -- For more details of this, see the documentation for 'UnionMBase' and + -- 'MergingStrategy'. + -- + -- To make a type compatible with the symbolic evaluation and merging in + -- Grisette, you need to implement the 'Mergeable' type class. + -- If you are only working with algebraic + -- data types, you can derive the 'Mergeable' instance automatically + -- For example: + -- + -- >>> :set -XDerivingStrategies + -- >>> :set -XDerivingVia + -- >>> :set -XDeriveGeneric + -- >>> import GHC.Generics + -- >>> :{ + -- data X = X SymInteger Integer + -- deriving (Generic, Show) + -- deriving (Mergeable) via (Default X) + -- :} + -- + -- This allows you to use the @UnionM@ type to represent values of type @X@, + -- and have them merged with the 'mrgIf' combinator: + -- + -- >>> mrgIf "c1" (mrgSingle $ X "b" 1) (mrgIf "c2" (mrgSingle $ X "c" 2) (mrgSingle $ X "d" 1)) :: UnionM X + -- {If (|| c1 (! c2)) (X (ite c1 b d) 1) (X c 2)} + -- + -- It is also possible to apply monad transformers onto @UnionM@ to extend + -- it with various mechanisms. + -- For example, by applying 'Control.Monad.Except.ExceptT', + -- you can symbolically evaluate a program with error handling. + -- To do this, you will need to define an error type and derive the 'Mergeable' + -- instance for it. Then, you can use the combinators provided by 'MonadError' + -- (and the @mrg*@ variants of them) for error handling, and the 'mrgIf' + -- combinator will also work with transformed @UnionM@ containers. + -- + -- Here's an example using the 'Control.Monad.Except.ExceptT' transformer + -- to model error handling in Grisette: + -- + -- >>> import Control.Monad.Except + -- >>> :{ + -- data Error = Fail + -- deriving (Show, Generic) + -- deriving (Mergeable) via (Default Error) + -- :} + -- + -- >>> mrgIf "a" (throwError Fail) (return "x") :: ExceptT Error UnionM SymInteger + -- ExceptT {If a (Left Fail) (Right x)} + -- + -- This will return a symbolic union value representing a program that + -- throws an error in the @then@ branch and returns a value in the @else@ + -- branch. + -- + -- __The following is the details of the merging algorithm.__ + -- __If you are not going to manually configure the system by writing a__ + -- __`MergingStrategy` and will only use the derived strategies,__ + -- __you can safely ignore the following contents in this section.__ + -- + -- In Grisette, the symbolic union has the Ordered Guards (ORG) + -- representation, which can be viewed as a nested if-then-else with some + -- representation invariant. + -- + -- For example, the following symbolic union represents a symbolic list of + -- symbolic integers with length 1, 2 or 3. The values are kept sorted in the + -- container: the list with length 1 is placed at the first place, the + -- list with length 2 is placed at the second place, and so on. + -- + -- \[ + -- \left\{\begin{aligned} + -- &\texttt{[a]}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{[b,b]}&&\mathrm{else~if}&&\texttt{c2}\\& + -- \texttt{[a,b,c]}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \] + -- + -- In Haskell syntax, the container is represented as the following nested + -- if-then-else tree + -- + -- > If c1 [a] (If c2 [b,b] [a,b,c]) + -- + -- The representations means that when @c1@ is true, then the value is a + -- list @[a]@, or when @c1@ is false and @c2@ is true, the value is a list + -- @[b,b]@, or otherwise the value is @[a,b,c]@. + -- + -- This representation allows you to use + -- the constructs that are not supported by the underlying solvers freely. + -- For example, when applying 'head' on this structure, we can just + -- distribute the 'head' function through the three branches, and get + -- + -- \[ + -- \left\{\begin{aligned} + -- &\texttt{head [a]}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{head [b,b]}&&\mathrm{else~if}&&\texttt{c2}\\ + -- &\texttt{head [a,b,c]}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \] + -- + -- or, equivalently + -- + -- \[ + -- \left\{\begin{aligned} + -- &\texttt{a}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{b}&&\mathrm{else~if}&&\texttt{c2}\\ + -- &\texttt{a}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \] + -- + -- Further symbolic evaluation will also distribute computations + -- over the branches in this result, and the identical branches will cause + -- redundant computation. To mitigate this, Grisette would try to merge + -- the branches, and the previous result would become + -- + -- \[ + -- \left\{\begin{aligned} + -- &\texttt{a}&&\mathrm{if}&&\texttt{c1}\vee\neg\texttt{c2}\\ + -- &\texttt{b}&&\mathrm{otherwise}\\ + -- \end{aligned}\right. + -- \] + -- + -- Note that if the contained type is symbolic Boolean, we may further merge + -- the values into a single formula. + -- + -- \[ + -- \left\{\begin{aligned}&\texttt{(ite c1 a (ite c2 b a))}&&\mathrm{unconditional}\end{aligned}\right. + -- \] + -- + -- In Grisette, such merging happens in the `mrgIf` or `unionIf` functions, + -- which model the symbolic conditional branching semantics. + -- To keep the merging efficient and generate small constraints, we enforce + -- that the symbolic union maintains the values in a sorted way, and merge + -- the unions with a mergesort-style merging algorithm. In the following + -- example, the two ORG containers passed to the 'mrgIf' are sorted + -- with the natural ordering on the integers. In the result, the values are + -- also organized in a sorted way, and the path conditions are correctly + -- maintained. + -- + -- \[ + -- \texttt{mrgIf}\left[ + -- \texttt{c}, + -- \left\{\begin{aligned} + -- &\texttt{1}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{3}&&\mathrm{else~if}&&\texttt{c2}\\ + -- &\texttt{4}&&\mathrm{otherwise} + -- \end{aligned}\right., + -- \left\{\begin{aligned} + -- &\texttt{1}&&\mathrm{if}&&\texttt{c3}\\ + -- &\texttt{2}&&\mathrm{else~if}&&\texttt{c4}\\ + -- &\texttt{4}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \right] + -- =\left\{\begin{aligned} + -- &\texttt{1}&&\mathrm{if}&&\texttt{(ite c c1 c3)}\\ + -- &\texttt{2}&&\mathrm{else~if}&&\texttt{(&& (! c) c3)}\\ + -- &\texttt{3}&&\mathrm{else~if}&&\texttt{(&& c c2)}\\ + -- &\texttt{4}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \] + -- + -- So far, we have described ORG as a flat list of values. + -- When the list is long, it is beneficial to partition the values and merge + -- (some or all) partitions into nested ORG values. + -- This hierarchical ORG representation is particularly useful for complex + -- data types, such as tuples, which tend to yield long lists. + -- + -- In the following example, @v*@ are values, while @t*@ are ORG containers. + -- The values in the containers are first partitioned into three groups: + -- @{v11, v12, v13}@, @{v2}@, and @{v13}@. + -- In each group, the values share some common features, (e.g., they are + -- constructed with the same data constructor). + -- The values in each group are organized in a subtree, e.g., the first group + -- is organized in the subtree @t1@. + -- The hierarchical representation also keeps a representation invariant: + -- at each level in the hierarchy, the values (or the subtrees) are also sorted + -- by some criteria. Here, in the first level, the values are sorted by the + -- constructor declaration order, and in the second level, the values are sorted + -- by the concrete field in the constructor @A@. + -- This criteria is given by the 'MergingStrategy' in the 'Mergeable' class, + -- called the root merging strategy of the type. + -- + -- > data X = A Integer SymInteger | B | C + -- + -- \[ + -- \left\{\begin{aligned} + -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{B}&&\mathrm{else if}&&\texttt{c2}\\ + -- &\texttt{C}&&\mathrm{otherwise}&& + -- \end{aligned}\right. + -- \hspace{2em}\mathrm{where}\hspace{2em} + -- \texttt{t1} = \left\{\begin{aligned} + -- &\texttt{A 1 a}&&\mathrm{if}&&\texttt{c11}\\ + -- &\texttt{A 3 b}&&\mathrm{else if}&&\texttt{c12}\\ + -- &\texttt{A 4 (&& x y)}&&\mathrm{otherwise}&& + -- \end{aligned}\right. + -- \] + -- + -- In Haskell syntax, it can be represented as follows: + -- + -- > If c1 (If c11 (A 1 a) (If c12 (A 3 b) (A 4 (&& x y)))) + -- > (If c2 B + -- > C) + -- + -- All the symbolic unions in Grisette should maintain the hierarchical + -- sorted invariant, and are sorted in the same way, with respect to the same + -- merging strategy (the root merging strategy for the type). + -- We can then merge the containers with a hierarchical + -- merging algorithm: at each level, we align the values and subtrees, and merge + -- the aligned ones. In the following example, 'mrgIf' resolves the root merging + -- strategy @s@, and calls the function @mrgIf'@, which accepts the merging strategy + -- as an argument. The symbolic union operands to the @mrgIf'@ function must be + -- sorted with the merging strategy passed to the function. + -- + -- Here we use the name of the subtrees and values to indicate the order of them: + -- + -- * @t1@ should be placed before @v3@ in the @then@ branch, + -- * @t1@ and @v4@ can be aligned with @t1'@ and @v4'@, respectively. + -- + -- The aligned subtrees will be merged recursively with @mrgIf'@, with a + -- __/sub-strategy/__ given by the merging strategy @s@ for the subtrees. + -- For example, @t1@ and @t1'@ will be merged with the sub-strategy @s'@. + -- The aligned values will be merged with a merging function, also given by + -- the merging strategy @s@. For example, @v4@ and @v4'@ will be merged with + -- the merging function @f'@. + -- + -- The ordering and the sub-strategies are abstracted with 'SortedStrategy', + -- and the merging functions will be wrapped in 'SimpleStrategy'. + -- The merging algorithm can then be configured by implementing the merging + -- strategies for the types contained in a symbolic union. See the documentation + -- for 'MergingStrategy' for details. + -- + -- \[ + -- \begin{aligned} + -- & \texttt{mrgIf}\left[ + -- \texttt{c}, + -- \left\{\begin{aligned} + -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{c2}\\ + -- &\texttt{v4}&&\mathrm{otherwise} + -- \end{aligned}\right., + -- \left\{\begin{aligned} + -- &\texttt{t1'}&&\mathrm{if}&&\texttt{c3}\\ + -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{c4}\\ + -- &\texttt{v4'}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \right]\\ + -- =~ & \texttt{mrgIf'}\left[ + -- \texttt{s}, + -- \texttt{c}, + -- \left\{\begin{aligned} + -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\ + -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{c2}\\ + -- &\texttt{v4}&&\mathrm{otherwise} + -- \end{aligned}\right., + -- \left\{\begin{aligned} + -- &\texttt{t1'}&&\mathrm{if}&&\texttt{c3}\\ + -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{c4}\\ + -- &\texttt{v4'}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \right]\\ + -- =~ & \left\{\begin{aligned} + -- &\texttt{mrgIf' s' c t1 t1'}&&\mathrm{if}&&\texttt{(ite c c1 c3)}\\ + -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{(&& (! c) c4)}\\ + -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{(&& c c2)}\\ + -- &\texttt{f' c v4 v4'}&&\mathrm{otherwise} + -- \end{aligned}\right. + -- \end{aligned} + -- \] + -- + -- For more details of the algorithm, please refer to + -- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). + + -- *** UnionM Monad + UnionM, + IsConcrete, + makeUnionWrapper, + makeUnionWrapper', + liftToMonadUnion, + + -- *** Merging + + -- **** Mergeable + Mergeable (..), + Mergeable1 (..), + rootStrategy1, + Mergeable2 (..), + rootStrategy2, + Mergeable3 (..), + rootStrategy3, + + -- **** Merging strategy + MergingStrategy (..), + derivedRootStrategy, + + -- **** Manual merging strategy construction + wrapStrategy, + product2Strategy, + DynamicSortedIdx (..), + StrategyList (..), + buildStrategyList, + resolveStrategy, + resolveStrategy', + + -- **** Simple mergeable types + SimpleMergeable (..), + SimpleMergeable1 (..), + mrgIte1, + SimpleMergeable2 (..), + mrgIte2, + + -- **** UnionLike operations + UnionLike (..), + mrgIf, + merge, + mrgSingle, + UnionPrjOp (..), + pattern SingleU, + pattern IfU, + MonadUnion, + simpleMerge, + onUnion, + onUnion2, + onUnion3, + onUnion4, + (#~), + + -- * Conversion between Concrete and Symbolic values + ToCon (..), + ToSym (..), + + -- * Symbolic Generation + + -- | It is usually useful to generate complex symbolic values. For example, + -- in program synthesis task, we may want to generate symbolic programs + -- to represent the search space given some specification. + -- + -- To help with this, we provide a set of classes and functions. The core + -- of the symbolic generation is the 'Fresh' monad, the 'GenSymSimple' class, + -- and the 'GenSym' class. + -- + -- The 'Fresh' monad is a combination of specialized state and reader + -- monads. It keeps an identifier, and an index. The generated symbolic + -- constants would be constructed with both the identifier and the index. + -- Each time a new symbolic constant is generated, the index would be + -- incremented. This keeps that the generated symbolic constants are unique. + -- + -- The 'GenSymSimple' class helps generate symbolic values that do not require + -- a symbolic union, for example, symbolic Booleans. + -- It provides the 'simpleFresh' function, which accepts a specification + -- for the symbolic values to generate. + -- + -- We do not need any specification to generate a symbolic Boolean, so + -- we provide a unit value as the specification: + -- + -- >>> runFresh (simpleFresh ()) "x" :: SymBool + -- x@0 + -- + -- We can generate a list of symbolic Booleans by specifying the length + -- of the list, and the specification for the elements. The two elements + -- in the generated list are unique as they have different indices. + -- + -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "x" :: [SymBool] + -- [x@0,x@1] + -- >>> runFresh (simpleFresh (SimpleListSpec 2 (SimpleListSpec 1 ()))) "x" :: [[SymBool]] + -- [[x@0],[x@1]] + -- + -- The 'GenSym' class helps generate symbolic values that require a symbolic + -- union, for example, lists with different lengths. + -- It provides the 'fresh' function, which accepts a specification + -- for the symbolic values to generate. + -- + -- We can generate a list of length 0, 1, or 2 by specifying the minimum + -- and maximum lengths, and the specification for the elements: + -- + -- >>> runFresh (fresh (ListSpec 0 2 ())) "x" :: UnionM [SymBool] + -- {If x@2 [] (If x@3 [x@1] [x@0,x@1])} + -- + -- We can generate many symbolic values at once with the 'Fresh' monad. + -- The symbolic constants are ensured to be unique: + -- + -- >>> :set -XScopedTypeVariables + -- >>> :{ + -- flip runFresh "x" $ do + -- a :: SymBool <- simpleFresh () + -- b :: UnionM [SymBool] <- fresh (ListSpec 0 2 ()) + -- return (a, b) + -- :} + -- (x@0,{If x@3 [] (If x@4 [x@2] [x@1,x@2])}) + -- + -- When you are just generating a symbolic value, and do not need to compose + -- multiple 'simpleFresh' or 'fresh' calls, you can use the 'genSym' and + -- 'genSymSimple' functions instead. + -- + -- >>> genSymSimple (SimpleListSpec 2 ()) "x" :: [SymBool] + -- [x@0,x@1] + -- >>> genSym (ListSpec 0 2 ()) "x" :: UnionM [SymBool] + -- {If x@2 [] (If x@3 [x@1] [x@0,x@1])} + -- + -- Symbolic choices from a list of symbolic values is very useful. + -- With the 'chooseFresh' function, + -- we can generate a symbolic value by choosing from a list of + -- alternative values. + -- Grisette would generate symbolic Boolean guards to perform the symbolic + -- choice. + -- + -- >>> :{ + -- (flip runFresh "x" $ do + -- a <- simpleFresh () + -- b <- simpleFresh () + -- chooseFresh [[a],[a,b],[a,a,b]]) :: UnionM [SymBool] + -- :} + -- {If x@2 [x@0] (If x@3 [x@0,x@1] [x@0,x@0,x@1])} + + -- ** Symbolic Generation Context + FreshIndex (..), + FreshIdent (..), + name, + nameWithInfo, + FileLocation (..), + nameWithLoc, + + -- ** Symbolic Generation Monad + MonadFresh (..), + Fresh, + FreshT, + runFresh, + runFreshT, + + -- ** Symbolic Generation Class + GenSym (..), + GenSymSimple (..), + genSym, + genSymSimple, + + -- ** Symbolic Generation Class Derivation + derivedNoSpecFresh, + derivedNoSpecSimpleFresh, + derivedSameShapeSimpleFresh, + + -- ** Symbolic choice + chooseFresh, + chooseSimpleFresh, + chooseUnionFresh, + choose, + chooseSimple, + chooseUnion, + + -- ** Useful specifications + EnumGenBound (..), + EnumGenUpperBound (..), + ListSpec (..), + SimpleListSpec (..), + + -- * Error Handling + + -- | + -- Grisette supports using 'Control.Monad.Except.ExceptT' to handle errors, + -- and provides the @mrg*@ variants for the combinators in "Grisette.Lib.Mtl", + -- for example, 'Grisette.Lib.Control.Monad.Except.mrgThrowError'. + -- + -- >>> import Control.Monad.Except + -- >>> import Grisette.Lib.Mtl + -- >>> mrgThrowError AssertionError :: ExceptT AssertionError UnionM () + -- ExceptT {Left AssertionError} + -- + -- You can define your own error types, and reason about them with the + -- solver APIs. + -- + -- >>> :set -XDerivingVia -XDeriveGeneric -XDerivingStrategies -XLambdaCase + -- >>> import GHC.Generics + -- >>> import Grisette.Backend.SBV + -- >>> :{ + -- data Error = Error1 | Error2 | Error3 + -- deriving (Show, Generic) + -- deriving (Mergeable) via Default Error + -- :} + -- + -- >>> let [a,b,c] = ["a","b","c"] :: [SymBool] + -- >>> res = mrgIf a (throwError Error1) (mrgIf b (return c) (throwError Error2)) :: ExceptT Error UnionM SymBool + -- >>> res + -- ExceptT {If (|| a (! b)) (If a (Left Error1) (Left Error2)) (Right c)} + -- >>> solveExcept (UnboundedReasoning z3) (\case Left _ -> con False; Right x -> x) res + -- Right (Model {a -> False :: Bool, b -> True :: Bool, c -> True :: Bool}) + -- + -- The solver call in the above example means that we want the solver to + -- find the conditions under which no error is thrown, and the result is + -- true. For more details, please refer to the + -- [documentation of the solver APIs](#solver). + -- + -- For those who prefer to encode errors as assertions and assumptions, + -- we provide the 'symAssert' and 'symAssume' functions. These functions + -- relies on the 'TransformError' type class to transform the assertions + -- and assumptions to the user-defined error type. + -- See their documentation for details. + + -- | #errors# + + -- ** Predefined errors + AssertionError (..), + VerificationConditions (..), + + -- ** Error transformation + TransformError (..), + symAssert, + symAssume, + symAssertTransformableError, + symThrowTransformableError, + + -- ** Simulate CBMC error handling + CBMCEither (..), + CBMCExceptT (..), + cbmcExcept, + mapCBMCExceptT, + withCBMCExceptT, + + -- * Solver backend + + -- | #solver# + + -- | Grisette abstracts the solver backend with the 'Solver' type class, + -- and the most basic solver call is the 'solve' function. + -- + -- In the following code, we will search for the integer solutions to two + -- equation systems. + -- The first equation system, as shown below, has the solution @(x, y) = (13, -7)@. + -- + -- \[ + -- \left\{ + -- \begin{aligned} + -- x + y &= 6 \\ + -- x - y &= 20 + -- \end{aligned} + -- \right. + -- \] + -- + -- The second equation system, as shown below, has no integer solutions. + -- + -- \[ + -- \left\{ + -- \begin{aligned} + -- x + y &= 6 \\ + -- x - y &= 19 + -- \end{aligned} + -- \right. + -- \] + -- + -- >>> import Grisette.IR.SymPrim + -- >>> import Grisette.Backend.SBV + -- >>> let x = "x" :: SymInteger + -- >>> let y = "y" :: SymInteger + -- >>> solve (UnboundedReasoning z3) (x + y ==~ 6 &&~ x - y ==~ 20) + -- Right (Model {x -> 13 :: Integer, y -> -7 :: Integer}) + -- >>> solve (UnboundedReasoning z3) (x + y ==~ 6 &&~ x - y ==~ 19) + -- Left Unsat + -- + -- The first parameter of 'solve' is the solver configuration. + -- Here it means that we should not perform any approximation, and should + -- use the Z3 solver. + -- + -- The second parameter is the formula to be solved. It have the type 'SymBool'. + -- + -- The 'solve' function would return a model if the formula is satisfiable. + -- The model is a mapping from symbolic variables to concrete values, + -- as shown in the following example. + -- + -- > Right (Model {x -> 13 :: Integer, y -> -7 :: Integer}) + -- + -- This model maps x to 13, and y to -7. With this model, we can then + -- evaluate symbolic values. The following code evaluates the product of + -- x and y under the solution of the equation system. + -- + -- >>> Right m <- solve (UnboundedReasoning z3) (x + y ==~ 6 &&~ x - y ==~ 20) + -- >>> evaluateSym False m (x * y) + -- -91 + -- + -- You may notice that the first argument to the 'evaluateSym' function is + -- a Boolean value 'False'. This argument controls whether the evaluation + -- should assign a default value to the symbolic constants that does not + -- appear in the model. When the argument is 'False', the evaluation would + -- preserve any symbolic constants that does not appear in the model, and + -- partially evaluate the expression. When the argument is 'True', the + -- evaluation would assign a default value to the symbolic constants that + -- does not appear in the model, e.g., 0 for integers, and the evaluation + -- result would become a concrete value -91. + -- + -- >>> let z = "z" :: SymInteger + -- >>> evaluateSym False m (x * y + z) + -- (+ -91 z) + -- >>> evaluateSym True m (x * y + z) + -- -91 + -- + -- Grisette also provides convenient functions to solve problems with error + -- handling. The lambda case function used in the following code means that + -- we would like the solver to find path that would not lead to an error. + -- This is done by mapping left values (failed paths) to false, and right + -- values (successful paths) to true. + -- + -- The following example finds bugs in a program in the hard way. It is an + -- overkill for such a simple program, but it is a good example to show how + -- to use Grisette to solve problems with error handling. + -- + -- We can first define the error type used in the program. + -- + -- >>> :set -XLambdaCase -XDeriveGeneric -XDerivingStrategies -XDerivingVia + -- >>> import Control.Monad.Except + -- >>> import Control.Exception + -- >>> import GHC.Generics + -- >>> :{ + -- data Error = Arith | Assert + -- deriving (Show, Generic) + -- deriving (Mergeable, SEq) via (Default Error) + -- :} + -- + -- Then we define how to transform the generic errors to the error type. + -- + -- >>> :{ + -- instance TransformError ArithException Error where + -- transformError _ = Arith + -- instance TransformError AssertionError Error where + -- transformError _ = Assert + -- :} + -- + -- Then we can perform the symbolic evaluation. The `divs` function throws + -- 'ArithException' when the divisor is 0, which would be transformed to + -- @Arith@, and the `symAssert` function would throw 'AssertionError' when + -- the condition is false, which would be transformed to @Assert@. + -- + -- >>> let x = "x" :: SymInteger + -- >>> let y = "y" :: SymInteger + -- >>> :{ + -- -- equivalent concrete program: + -- -- let x = x `div` y + -- -- if z > 0 then assert (x >= y) else return () + -- res :: ExceptT Error UnionM () + -- res = do + -- z <- x `divs` y + -- mrgIf (z >~ 0) (symAssert (x >=~ y)) (return ()) + -- :} + -- + -- Then we can ask the solver to find a counter-example that would lead to + -- an assertion violation error, but do not trigger the division by zero + -- error. + -- This can be done by asking the solver to find a path that produce + -- @Left Assert@. + -- + -- >>> res + -- ExceptT {If (|| (= y 0) (&& (< 0 (div x y)) (! (<= y x)))) (If (= y 0) (Left Arith) (Left Assert)) (Right ())} + -- + -- > >>> solveExcept (UnboundedReasoning z3) (==~ Left Assert) res + -- > Right (Model {x -> -6 :: Integer, y -> -3 :: Integer}) -- possible output + -- + -- Grisette also provide implementation for counter-example guided inductive + -- synthesis (CEGIS) algorithm. See the documentation for 'CEGISSolver' for + -- more details. + + -- ** Solver interface + Solver (..), + UnionWithExcept (..), + solveExcept, + solveMultiExcept, + + -- ** Counter-example Guided Inductive Synthesis (CEGIS) + CEGISSolver (..), + CEGISCondition (..), + cegisPostCond, + cegisPrePost, + cegis, + cegisExcept, + cegisExceptStdVC, + cegisExceptVC, + cegisExceptMultiInputs, + cegisExceptStdVCMultiInputs, + cegisExceptVCMultiInputs, + + -- ** Symbolic constant extraction + + -- Grisette supports the extraction of the symbolic constant symbols from a + -- symbolic value. This is useful for manipulating the models returned by + -- the solver. The builtin CEGIS procedure relies on this. + SymbolSetOps (..), + SymbolSetRep (..), + ExtractSymbolics (..), + + -- ** Evaluation with a model + + -- | + -- When given a satisfiable formula, a solver can return a model that specifies + -- the concrete assignments of the variables in the formula to make the formula + -- true. We can use this model to evaluate some symbolic values by substituting + -- the symbolic constants with the concrete assignments. + ModelOps (..), + ModelRep (..), + EvaluateSym (..), + evaluateSymToCon, + + -- ** Substitution of a symbol + SubstituteSym (..), + SubstituteSym' (..), + + -- * Type Class Derivation + Default (..), + Default1 (..), + + -- * Utilities + + -- ** Memoization + htmemo, + htmemo2, + htmemo3, + htmup, + htmemoFix, + + -- ** Bundled Constructor Wrappers + mrgTrue, + mrgFalse, + mrgUnit, + mrgTuple2, + mrgTuple3, + mrgJust, + mrgNothing, + mrgLeft, + mrgRight, + mrgInL, + mrgInR, + mrgAssertionViolation, + mrgAssumptionViolation, + ) +where + +import Generics.Deriving (Default (..), Default1 (..)) +import Grisette.Core.BuiltinUnionWrappers +import Grisette.Core.Control.Exception +import Grisette.Core.Control.Monad.CBMCExcept +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Control.Monad.UnionM +import Grisette.Core.Data.Class.BitVector +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.CEGISSolver +import Grisette.Core.Data.Class.Error +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Function +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.Integer +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.ModelOps +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.Solver +import Grisette.Core.Data.Class.Substitute +import Grisette.Core.Data.Class.ToCon +import Grisette.Core.Data.Class.ToSym +import Grisette.Core.Data.FileLocation +import Grisette.Core.Data.MemoUtils +import Grisette.Core.TH + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.Lib.Base +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies diff --git a/src/Grisette/Core/BuiltinUnionWrappers.hs b/src/Grisette/Core/BuiltinUnionWrappers.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/BuiltinUnionWrappers.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.BuiltinUnionWrapper +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.BuiltinUnionWrappers + ( -- * Builtin constructor wrappers for some common data types + mrgTrue, + mrgFalse, + mrgUnit, + mrgTuple2, + mrgTuple3, + mrgJust, + mrgNothing, + mrgLeft, + mrgRight, + mrgInL, + mrgInR, + mrgAssertionViolation, + mrgAssumptionViolation, + ) +where + +import Data.Functor.Sum +import Grisette.Core.Control.Exception +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.TH + +$(makeUnionWrapper "mrg" ''Bool) +$(makeUnionWrapper' ["mrgUnit"] ''()) +$(makeUnionWrapper' ["mrgTuple2"] ''(,)) +$(makeUnionWrapper' ["mrgTuple3"] ''(,,)) +$(makeUnionWrapper "mrg" ''Maybe) +$(makeUnionWrapper "mrg" ''Either) +$(makeUnionWrapper "mrg" ''Sum) +$(makeUnionWrapper "mrg" ''VerificationConditions) diff --git a/src/Grisette/Core/Control/Exception.hs b/src/Grisette/Core/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Control/Exception.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.Control.Exception +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Control.Exception + ( -- * Predefined exceptions + AssertionError (..), + VerificationConditions (..), + symAssert, + symAssume, + ) +where + +import Control.DeepSeq +import Control.Exception +import Control.Monad.Except +import GHC.Generics +import Generics.Deriving +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Error +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.ToCon +import Grisette.Core.Data.Class.ToSym +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.Lib.Base +-- >>> import Grisette.IR.SymPrim +-- >>> import Control.Monad.Trans.Except + +-- | Assertion error. +data AssertionError = AssertionError + deriving (Show, Eq, Ord, Generic, NFData) + deriving (ToCon AssertionError, ToSym AssertionError) via (Default AssertionError) + +deriving via (Default AssertionError) instance Mergeable AssertionError + +deriving via (Default AssertionError) instance SimpleMergeable AssertionError + +deriving via (Default AssertionError) instance SEq AssertionError + +instance SOrd AssertionError where + _ <=~ _ = con True + _ <~ _ = con False + _ >=~ _ = con True + _ >~ _ = con False + _ `symCompare` _ = mrgSingle EQ + +deriving via (Default AssertionError) instance EvaluateSym AssertionError + +deriving via (Default AssertionError) instance ExtractSymbolics AssertionError + +-- | Verification conditions. +-- A crashed program path can terminate with either assertion violation errors or assumption violation errors. +data VerificationConditions + = AssertionViolation + | AssumptionViolation + deriving (Show, Eq, Ord, Generic, NFData) + deriving (ToCon VerificationConditions, ToSym VerificationConditions) via (Default VerificationConditions) + +deriving via (Default VerificationConditions) instance Mergeable VerificationConditions + +deriving via (Default VerificationConditions) instance SEq VerificationConditions + +instance SOrd VerificationConditions where + l >=~ r = con $ l <= r + l >~ r = con $ l < r + l <=~ r = con $ l >= r + l <~ r = con $ l > r + l `symCompare` r = mrgSingle $ l `compare` r + +deriving via (Default VerificationConditions) instance EvaluateSym VerificationConditions + +deriving via (Default VerificationConditions) instance ExtractSymbolics VerificationConditions + +instance TransformError VerificationConditions VerificationConditions where + transformError = id + +instance TransformError AssertionError VerificationConditions where + transformError _ = AssertionViolation + +instance TransformError ArithException AssertionError where + transformError _ = AssertionError + +instance TransformError ArrayException AssertionError where + transformError _ = AssertionError + +instance TransformError AssertionError AssertionError where + transformError = id + +-- | Used within a monadic multi path computation to begin exception processing. +-- +-- Checks the condition passed to the function. +-- The current execution path will be terminated with assertion error if the condition is false. +-- +-- If the condition is symbolic, Grisette will split the execution into two paths based on the condition. +-- The symbolic execution will continue on the then-branch, where the condition is true. +-- For the else branch, where the condition is false, the execution will be terminated. +-- +-- The resulting monadic environment should be compatible with the 'AssertionError' +-- error type. See 'TransformError' type class for details. +-- +-- __/Examples/__: +-- +-- Terminates the execution if the condition is false. +-- Note that we may lose the 'Mergeable' knowledge here if no possible execution +-- path is viable. This may affect the efficiency in theory, but in practice this +-- should not be a problem as all paths are terminated and no further evaluation +-- would be performed. +-- +-- >>> symAssert (con False) :: ExceptT AssertionError UnionM () +-- ExceptT {Left AssertionError} +-- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- ExceptT +-- +-- No effect if the condition is true: +-- +-- >>> symAssert (con True) :: ExceptT AssertionError UnionM () +-- ExceptT {Right ()} +-- >>> do; symAssert (con True); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- ExceptT {Right 1} +-- +-- Splitting the path and terminate one of them when the condition is symbolic. +-- +-- >>> symAssert (ssym "a") :: ExceptT AssertionError UnionM () +-- ExceptT {If (! a) (Left AssertionError) (Right ())} +-- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- ExceptT {If (! a) (Left AssertionError) (Right 1)} +-- +-- 'AssertionError' is compatible with 'VerificationConditions': +-- +-- >>> symAssert (ssym "a") :: ExceptT VerificationConditions UnionM () +-- ExceptT {If (! a) (Left AssertionViolation) (Right ())} +symAssert :: + (TransformError AssertionError to, Mergeable to, MonadError to erm, MonadUnion erm) => + SymBool -> + erm () +symAssert = symAssertTransformableError AssertionError + +-- | Used within a monadic multi path computation to begin exception processing. +-- +-- Similar to 'symAssert', but terminates the execution path with 'AssumptionViolation' error. +-- +-- /Examples/: +-- +-- >>> symAssume (ssym "a") :: ExceptT VerificationConditions UnionM () +-- ExceptT {If (! a) (Left AssumptionViolation) (Right ())} +symAssume :: + (TransformError VerificationConditions to, Mergeable to, MonadError to erm, MonadUnion erm) => + SymBool -> + erm () +symAssume = symAssertTransformableError AssumptionViolation diff --git a/src/Grisette/Core/Control/Monad/CBMCExcept.hs b/src/Grisette/Core/Control/Monad/CBMCExcept.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Control/Monad/CBMCExcept.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Control.Monad.CBMCExcept +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Control.Monad.CBMCExcept + ( -- * CBMC-like error handling + CBMCEither (..), + CBMCExceptT (..), + cbmcExcept, + mapCBMCExceptT, + withCBMCExceptT, + OrigExcept.MonadError (..), + ) +where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import qualified Control.Monad.Except as OrigExcept +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Zip +import Data.Functor.Classes +import Data.Functor.Contravariant +import Data.Hashable +import GHC.Generics +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solver +import Grisette.Core.Data.Class.ToCon +import Grisette.Core.Data.Class.ToSym +import Language.Haskell.TH.Syntax (Lift) +import Unsafe.Coerce + +-- | A wrapper type for 'Either'. Uses different merging strategies. +newtype CBMCEither a b = CBMCEither {runCBMCEither :: Either a b} + deriving newtype (Eq, Eq1, Ord, Ord1, Read, Read1, Show, Show1, Functor, Applicative, Monad, Hashable, NFData) + deriving stock (Generic, Lift) + +deriving newtype instance (SEq e, SEq a) => SEq (CBMCEither e a) + +deriving newtype instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (CBMCEither a b) + +deriving newtype instance + (ExtractSymbolics a, ExtractSymbolics b) => + ExtractSymbolics (CBMCEither a b) + +instance + ( GenSymSimple a a, + Mergeable a, + GenSymSimple b b, + Mergeable b + ) => + GenSym (CBMCEither a b) (CBMCEither a b) + +instance + ( GenSymSimple a a, + GenSymSimple b b + ) => + GenSymSimple (CBMCEither a b) (CBMCEither a b) + where + simpleFresh = derivedSameShapeSimpleFresh + +instance + (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => + GenSym () (CBMCEither a b) + where + fresh = derivedNoSpecFresh + +deriving newtype instance (SOrd a, SOrd b) => SOrd (CBMCEither a b) + +deriving newtype instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (CBMCEither e2 a2) + +instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (CBMCEither e2 a2) where + toCon (CBMCEither a) = CBMCEither <$> toCon a + +instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (Either e2 a2) where + toCon (CBMCEither a) = toCon a + +deriving newtype instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (CBMCEither e2 a2) + +instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (CBMCEither e2 a2) where + toSym (CBMCEither a) = CBMCEither $ toSym a + +instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (Either e2 a2) where + toSym (CBMCEither a) = toSym a + +data EitherIdx idx = L idx | R deriving (Eq, Ord, Show) + +instance (Mergeable e, Mergeable a) => Mergeable (CBMCEither e a) where + rootStrategy = rootStrategy1 + +instance (Mergeable e) => Mergeable1 (CBMCEither e) where + liftRootStrategy ms = case rootStrategy of + SimpleStrategy m -> + SortedStrategy + ( \(CBMCEither e) -> case e of + Left _ -> False + Right _ -> True + ) + ( \case + False -> SimpleStrategy $ + \cond (CBMCEither le) (CBMCEither re) -> case (le, re) of + (Left l, Left r) -> CBMCEither $ Left $ m cond l r + _ -> error "impossible" + True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") + ) + NoStrategy -> + SortedStrategy + ( \(CBMCEither e) -> case e of + Left _ -> False + Right _ -> True + ) + ( \case + False -> NoStrategy + True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") + ) + SortedStrategy idx sub -> + SortedStrategy + ( \(CBMCEither e) -> case e of + Left v -> L $ idx v + Right _ -> R + ) + ( \case + L i -> wrapStrategy (sub i) (CBMCEither . Left) (\case (CBMCEither (Left x)) -> x; _ -> error "impossible") + R -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") + ) + +cbmcEither :: forall a c b. (a -> c) -> (b -> c) -> CBMCEither a b -> c +cbmcEither l r v = either l r (unsafeCoerce v) + +-- | Wrap an 'Either' value in 'CBMCExceptT' +cbmcExcept :: (Monad m) => Either e a -> CBMCExceptT e m a +cbmcExcept m = CBMCExceptT (return $ CBMCEither m) + +-- | Map the error and values in a 'CBMCExceptT' +mapCBMCExceptT :: (m (Either e a) -> n (Either e' b)) -> CBMCExceptT e m a -> CBMCExceptT e' n b +mapCBMCExceptT f m = CBMCExceptT $ (unsafeCoerce . f . unsafeCoerce) (runCBMCExceptT m) + +-- | Map the error in a 'CBMCExceptT' +withCBMCExceptT :: Functor m => (e -> e') -> CBMCExceptT e m a -> CBMCExceptT e' m a +withCBMCExceptT f = mapCBMCExceptT $ fmap $ either (Left . f) Right + +-- | Similar to 'ExceptT', but with different error handling mechanism. +newtype CBMCExceptT e m a = CBMCExceptT {runCBMCExceptT :: m (CBMCEither e a)} deriving stock (Generic, Generic1) + +instance (Eq e, Eq1 m) => Eq1 (CBMCExceptT e m) where + liftEq eq (CBMCExceptT x) (CBMCExceptT y) = liftEq (liftEq eq) x y + {-# INLINE liftEq #-} + +instance (Ord e, Ord1 m) => Ord1 (CBMCExceptT e m) where + liftCompare comp (CBMCExceptT x) (CBMCExceptT y) = + liftCompare (liftCompare comp) x y + {-# INLINE liftCompare #-} + +instance (Read e, Read1 m) => Read1 (CBMCExceptT e m) where + liftReadsPrec rp rl = + readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "CBMCExceptT" CBMCExceptT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show e, Show1 m) => Show1 (CBMCExceptT e m) where + liftShowsPrec sp sl d (CBMCExceptT m) = + showsUnaryWith (liftShowsPrec sp' sl') "CBMCExceptT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq e, Eq1 m, Eq a) => Eq (CBMCExceptT e m a) where + (==) = eq1 + +instance (Ord e, Ord1 m, Ord a) => Ord (CBMCExceptT e m a) where + compare = compare1 + +instance (Read e, Read1 m, Read a) => Read (CBMCExceptT e m a) where + readsPrec = readsPrec1 + +instance (Show e, Show1 m, Show a) => Show (CBMCExceptT e m a) where + showsPrec = showsPrec1 + +instance (Functor m) => Functor (CBMCExceptT e m) where + fmap f = CBMCExceptT . fmap (fmap f) . runCBMCExceptT + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (CBMCExceptT e f) where + foldMap f (CBMCExceptT a) = foldMap (cbmcEither (const mempty) f) a + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (CBMCExceptT e f) where + traverse f (CBMCExceptT a) = + CBMCExceptT <$> traverse (cbmcEither (pure . CBMCEither . Left) (fmap (CBMCEither . Right) . f)) a + {-# INLINE traverse #-} + +instance (Functor m, Monad m) => Applicative (CBMCExceptT e m) where + pure a = CBMCExceptT $ return (CBMCEither . Right $ a) + {-# INLINE pure #-} + CBMCExceptT f <*> CBMCExceptT v = CBMCExceptT $ do + mf <- f + case mf of + CBMCEither (Left e) -> return (CBMCEither . Left $ e) + CBMCEither (Right k) -> do + mv <- v + case mv of + CBMCEither (Left e) -> return (CBMCEither . Left $ e) + CBMCEither (Right x) -> return (CBMCEither . Right $ k x) + {-# INLINEABLE (<*>) #-} + m *> k = m >> k + {-# INLINE (*>) #-} + +instance (Functor m, Monad m, Monoid e) => Alternative (CBMCExceptT e m) where + empty = CBMCExceptT $ return (CBMCEither . Left $ mempty) + {-# INLINE empty #-} + CBMCExceptT mx <|> CBMCExceptT my = CBMCExceptT $ do + ex <- mx + case ex of + CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my + CBMCEither (Right x) -> return (CBMCEither . Right $ x) + {-# INLINEABLE (<|>) #-} + +instance (Monad m) => Monad (CBMCExceptT e m) where + m >>= k = CBMCExceptT $ do + a <- runCBMCExceptT m + case a of + CBMCEither (Left e) -> return (CBMCEither $ Left e) + CBMCEither (Right x) -> runCBMCExceptT (k x) + {-# INLINE (>>=) #-} + +instance (Fail.MonadFail m) => Fail.MonadFail (CBMCExceptT e m) where + fail = CBMCExceptT . Fail.fail + {-# INLINE fail #-} + +instance (Monad m, Monoid e) => MonadPlus (CBMCExceptT e m) where + mzero = CBMCExceptT $ return (CBMCEither $ Left mempty) + {-# INLINE mzero #-} + CBMCExceptT mx `mplus` CBMCExceptT my = CBMCExceptT $ do + ex <- mx + case ex of + CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my + CBMCEither (Right x) -> return (CBMCEither $ Right x) + {-# INLINEABLE mplus #-} + +instance (MonadFix m) => MonadFix (CBMCExceptT e m) where + mfix f = CBMCExceptT (mfix (runCBMCExceptT . f . cbmcEither (const bomb) id)) + where + bomb = error "mfix (CBMCExceptT): inner computation returned Left value" + {-# INLINE mfix #-} + +instance MonadTrans (CBMCExceptT e) where + lift = CBMCExceptT . fmap (CBMCEither . Right) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (CBMCExceptT e m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (MonadZip m) => MonadZip (CBMCExceptT e m) where + mzipWith f (CBMCExceptT a) (CBMCExceptT b) = CBMCExceptT $ mzipWith (liftA2 f) a b + {-# INLINE mzipWith #-} + +instance Contravariant m => Contravariant (CBMCExceptT e m) where + contramap f = CBMCExceptT . contramap (fmap f) . runCBMCExceptT + {-# INLINE contramap #-} + +throwE :: (Monad m) => e -> CBMCExceptT e m a +throwE = CBMCExceptT . return . CBMCEither . Left +{-# INLINE throwE #-} + +catchE :: + (Monad m) => + CBMCExceptT e m a -> + (e -> CBMCExceptT e' m a) -> + CBMCExceptT e' m a +m `catchE` h = CBMCExceptT $ do + a <- runCBMCExceptT m + case a of + CBMCEither (Left l) -> runCBMCExceptT (h l) + CBMCEither (Right r) -> return (CBMCEither . Right $ r) +{-# INLINE catchE #-} + +instance Monad m => OrigExcept.MonadError e (CBMCExceptT e m) where + throwError = throwE + {-# INLINE throwError #-} + catchError = catchE + {-# INLINE catchError #-} + +instance (SEq (m (CBMCEither e a))) => SEq (CBMCExceptT e m a) where + (CBMCExceptT a) ==~ (CBMCExceptT b) = a ==~ b + {-# INLINE (==~) #-} + +instance (EvaluateSym (m (CBMCEither e a))) => EvaluateSym (CBMCExceptT e m a) where + evaluateSym fillDefault model (CBMCExceptT v) = CBMCExceptT $ evaluateSym fillDefault model v + {-# INLINE evaluateSym #-} + +instance + (ExtractSymbolics (m (CBMCEither e a))) => + ExtractSymbolics (CBMCExceptT e m a) + where + extractSymbolics (CBMCExceptT v) = extractSymbolics v + +instance + (Mergeable1 m, Mergeable e, Mergeable a) => + Mergeable (CBMCExceptT e m a) + where + rootStrategy = wrapStrategy rootStrategy1 CBMCExceptT runCBMCExceptT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable e) => Mergeable1 (CBMCExceptT e m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) CBMCExceptT runCBMCExceptT + {-# INLINE liftRootStrategy #-} + +instance + {-# OVERLAPPABLE #-} + ( GenSym spec (m (CBMCEither a b)), + Mergeable1 m, + Mergeable a, + Mergeable b + ) => + GenSym spec (CBMCExceptT a m b) + where + fresh v = do + x <- fresh v + return $ merge . fmap CBMCExceptT $ x + +instance + {-# OVERLAPPABLE #-} + ( GenSymSimple spec (m (CBMCEither a b)) + ) => + GenSymSimple spec (CBMCExceptT a m b) + where + simpleFresh v = CBMCExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)) + ) => + GenSymSimple (CBMCExceptT e m a) (CBMCExceptT e m a) + where + simpleFresh (CBMCExceptT v) = CBMCExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)), + Mergeable1 m, + Mergeable e, + Mergeable a + ) => + GenSym (CBMCExceptT e m a) (CBMCExceptT e m a) + +instance + (UnionLike m, Mergeable e, Mergeable a) => + SimpleMergeable (CBMCExceptT e m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (UnionLike m, Mergeable e) => + SimpleMergeable1 (CBMCExceptT e m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (UnionLike m, Mergeable e) => + UnionLike (CBMCExceptT e m) + where + mergeWithStrategy s (CBMCExceptT v) = CBMCExceptT $ mergeWithStrategy (liftRootStrategy s) v + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f + {-# INLINE mrgIfWithStrategy #-} + single = CBMCExceptT . single . return + {-# INLINE single #-} + unionIf cond (CBMCExceptT l) (CBMCExceptT r) = CBMCExceptT $ unionIf cond l r + {-# INLINE unionIf #-} + +instance (SOrd (m (CBMCEither e a))) => SOrd (CBMCExceptT e m a) where + (CBMCExceptT l) <=~ (CBMCExceptT r) = l <=~ r + (CBMCExceptT l) <~ (CBMCExceptT r) = l <~ r + (CBMCExceptT l) >=~ (CBMCExceptT r) = l >=~ r + (CBMCExceptT l) >~ (CBMCExceptT r) = l >~ r + symCompare (CBMCExceptT l) (CBMCExceptT r) = symCompare l r + +instance + ToCon (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b)) => + ToCon (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b) + where + toCon (CBMCExceptT v) = CBMCExceptT <$> toCon v + +instance + ToCon (m1 (CBMCEither e1 a)) (Either e2 b) => + ToCon (CBMCExceptT e1 m1 a) (Either e2 b) + where + toCon (CBMCExceptT v) = toCon v + +instance + (ToSym (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) => + ToSym (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b) + where + toSym (CBMCExceptT v) = CBMCExceptT $ toSym v + +instance + (Monad u, UnionLike u, Mergeable e, Mergeable v) => + UnionWithExcept (CBMCExceptT e u v) u e v + where + extractUnionExcept = merge . fmap runCBMCEither . runCBMCExceptT diff --git a/src/Grisette/Core/Control/Monad/Union.hs b/src/Grisette/Core/Control/Monad/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Control/Monad/Union.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Control.Monad.Union +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Control.Monad.Union + ( -- * MonadUnion + MonadUnion, + ) +where + +import Grisette.Core.Data.Class.SimpleMergeable + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | Class for monads that support union-like operations and 'Mergeable' knowledge propagation. +type MonadUnion u = (UnionLike u, Monad u) diff --git a/src/Grisette/Core/Control/Monad/UnionM.hs b/src/Grisette/Core/Control/Monad/UnionM.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Control/Monad/UnionM.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -fno-cse #-} + +{-# HLINT ignore "Use <&>" #-} + +-- {-# OPTIONS_GHC -fno-full-laziness #-} + +-- | +-- Module : Grisette.Core.Control.Monad.UnionM +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Control.Monad.UnionM + ( -- * UnionM and helpers + UnionM (..), + liftToMonadUnion, + underlyingUnion, + isMerged, + (#~), + IsConcrete, + ) +where + +import Control.DeepSeq +import Control.Monad.Identity (Identity (..)) +import Data.Functor.Classes +import qualified Data.HashMap.Lazy as HML +import Data.Hashable +import Data.IORef +import Data.String +import GHC.IO hiding (evaluate) +import Grisette.Core.Control.Monad.CBMCExcept +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Function +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.Solver +import Grisette.Core.Data.Class.Substitute +import Grisette.Core.Data.Class.ToCon +import Grisette.Core.Data.Class.ToSym +import Grisette.Core.Data.Union +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Compat (unTypeSplice) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XScopedTypeVariables + +-- | 'UnionM' is the 'Union' container (hidden) enhanced with +-- 'MergingStrategy' +-- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). +-- +-- The 'Union' models the underlying semantics evaluation semantics for +-- unsolvable types with the nested if-then-else tree semantics, and can be +-- viewed as the following structure: +-- +-- > data Union a +-- > = Single a +-- > | If bool (Union a) (Union a) +-- +-- The 'Single' constructor is for a single value with the path condition +-- @true@, and the 'If' constructor is the if operator in an if-then-else +-- tree. +-- For clarity, when printing a 'UnionM' value, we will omit the 'Single' +-- constructor. The following two representations has the same semantics. +-- +-- > If c1 (If c11 v11 (If c12 v12 v13)) +-- > (If c2 v2 +-- > v3) +-- +-- \[ +-- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. +-- \] +-- +-- To reduce the size of the if-then-else tree to reduce the number of paths to +-- execute, Grisette would merge the branches in a 'Union' container and +-- maintain a representation invariant for them. To perform this merging +-- procedure, Grisette relies on a type class called 'Mergeable' and the +-- merging strategy defined by it. +-- +-- 'Union' is a monad, so we can easily write code with the do-notation and +-- monadic combinators. However, the standard monadic operators cannot +-- resolve any extra constraints, including the 'Mergeable' constraint (see +-- [The constrained-monad +-- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) +-- by Sculthorpe et al.). +-- This prevents the standard do-notations to merge the results automatically, +-- and would result in bad performance or very verbose code. +-- +-- To reduce this boilerplate, Grisette provide another monad, 'UnionM' that +-- would try to cache the merging strategy. +-- The 'UnionM' has two data constructors (hidden intentionally), 'UAny' and 'UMrg'. +-- The 'UAny' data constructor (printed as @<@@...@@>@) wraps an arbitrary (probably +-- unmerged) 'Union'. It is constructed when no 'Mergeable' knowledge is +-- available (for example, when constructed with Haskell\'s 'return'). +-- The 'UMrg' data constructor (printed as @{...}@) wraps a merged 'UnionM' along with the +-- 'Mergeable' constraint. This constraint can be propagated to the contexts +-- without 'Mergeable' knowledge, and helps the system to merge the resulting +-- 'Union'. +-- +-- __/Examples:/__ +-- +-- 'return' cannot resolve the 'Mergeable' constraint. +-- +-- >>> return 1 :: UnionM Integer +-- <1> +-- +-- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. +-- +-- >>> import Grisette.Lib.Base +-- >>> mrgReturn 1 :: UnionM Integer +-- {1} +-- +-- 'unionIf' cannot resolve the 'Mergeable' constraint. +-- +-- >>> unionIf "a" (return 1) (unionIf "b" (return 1) (return 2)) :: UnionM Integer +-- +-- +-- But 'unionIf' is able to merge the result if some of the branches are merged: +-- +-- >>> unionIf "a" (return 1) (unionIf "b" (mrgReturn 1) (return 2)) :: UnionM Integer +-- {If (|| a b) 1 2} +-- +-- The '>>=' operator uses 'unionIf' internally. When the final statement in a do-block +-- merges the values, the system can then merge the final result. +-- +-- >>> :{ +-- do +-- x <- unionIf (ssym "a") (return 1) (unionIf (ssym "b") (return 1) (return 2)) +-- mrgSingle $ x + 1 :: UnionM Integer +-- :} +-- {If (|| a b) 2 3} +-- +-- Calling a function that merges a result at the last line of a do-notation +-- will also merge the whole block. If you stick to these @mrg*@ combinators and +-- all the functions will merge the results, the whole program can be +-- symbolically evaluated efficiently. +-- +-- >>> f x y = mrgIf "c" x y +-- >>> :{ +-- do +-- x <- unionIf (ssym "a") (return 1) (unionIf (ssym "b") (return 1) (return 2)) +-- f x (x + 1) :: UnionM Integer +-- :} +-- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} +-- +-- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ +-- variants of other combinators. You should stick to these combinators to +-- ensure efficient merging by Grisette. +data UnionM a where + -- | 'UnionM' with no 'Mergeable' knowledge. + UAny :: + -- | (Possibly) cached merging result. + IORef (Either (Union a) (UnionM a)) -> + -- | Original 'Union'. + Union a -> + UnionM a + -- | 'UnionM' with 'Mergeable' knowledge. + UMrg :: + -- | Cached merging strategy. + MergingStrategy a -> + -- | Merged Union + Union a -> + UnionM a + +instance (NFData a) => NFData (UnionM a) where + rnf = rnf1 + +instance NFData1 UnionM where + liftRnf _a (UAny i m) = rnf i `seq` liftRnf _a m + liftRnf _a (UMrg _ m) = liftRnf _a m + +instance (Lift a) => Lift (UnionM a) where + liftTyped (UAny _ v) = [||freshUAny v||] + liftTyped (UMrg _ v) = [||freshUAny v||] + lift = unTypeSplice . liftTyped + +freshUAny :: Union a -> UnionM a +freshUAny v = UAny (unsafeDupablePerformIO $ newIORef $ Left v) v +{-# NOINLINE freshUAny #-} + +instance (Show a) => (Show (UnionM a)) where + showsPrec = showsPrec1 + +liftShowsPrecUnion :: + forall a. + (Int -> a -> ShowS) -> + ([a] -> ShowS) -> + Int -> + Union a -> + ShowS +liftShowsPrecUnion sp _ i (Single a) = sp i a +liftShowsPrecUnion sp sl i (If _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrecUnion sp sl + +wrapBracket :: Char -> Char -> ShowS -> ShowS +wrapBracket l r p = showChar l . p . showChar r + +instance Show1 UnionM where + liftShowsPrec sp sl i (UAny _ a) = + wrapBracket '<' '>' + . liftShowsPrecUnion sp sl 0 + $ a + liftShowsPrec sp sl i (UMrg _ a) = + wrapBracket '{' '}' + . liftShowsPrecUnion sp sl 0 + $ a + +-- | Extract the underlying Union. May be unmerged. +underlyingUnion :: UnionM a -> Union a +underlyingUnion (UAny _ a) = a +underlyingUnion (UMrg _ a) = a +{-# INLINE underlyingUnion #-} + +-- | Check if a UnionM is already merged. +isMerged :: UnionM a -> Bool +isMerged UAny {} = False +isMerged UMrg {} = True +{-# INLINE isMerged #-} + +instance UnionPrjOp UnionM where + singleView = singleView . underlyingUnion + {-# INLINE singleView #-} + ifView (UAny _ u) = case ifView u of + Just (c, t, f) -> Just (c, freshUAny t, freshUAny f) + Nothing -> Nothing + ifView (UMrg m u) = case ifView u of + Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) + Nothing -> Nothing + {-# INLINE ifView #-} + leftMost = leftMost . underlyingUnion + {-# INLINE leftMost #-} + +instance Functor UnionM where + fmap f fa = fa >>= return . f + {-# INLINE fmap #-} + +instance Applicative UnionM where + pure = single + {-# INLINE pure #-} + f <*> a = f >>= (\xf -> a >>= (return . xf)) + {-# INLINE (<*>) #-} + +bindUnion :: Union a -> (a -> UnionM b) -> UnionM b +bindUnion (Single a') f' = f' a' +bindUnion (If _ _ cond ifTrue ifFalse) f' = + unionIf cond (bindUnion ifTrue f') (bindUnion ifFalse f') +{-# INLINE bindUnion #-} + +instance Monad UnionM where + a >>= f = bindUnion (underlyingUnion a) f + {-# INLINE (>>=) #-} + +instance (Mergeable a) => Mergeable (UnionM a) where + rootStrategy = SimpleStrategy $ \cond t f -> unionIf cond t f >>= mrgSingle + {-# INLINE rootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (UnionM a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance Mergeable1 UnionM where + liftRootStrategy m = SimpleStrategy $ \cond t f -> unionIf cond t f >>= (UMrg m . Single) + {-# INLINE liftRootStrategy #-} + +instance SimpleMergeable1 UnionM where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance UnionLike UnionM where + mergeWithStrategy _ m@(UMrg _ _) = m + mergeWithStrategy s (UAny ref u) = unsafeDupablePerformIO $ + atomicModifyIORef' ref $ \case + x@(Right r) -> (x, r) + Left _ -> (Right r, r) + where + !r = UMrg s $ fullReconstruct s u -- m >>= mrgSingle + {-# NOINLINE mergeWithStrategy #-} + mrgIfWithStrategy s (Con c) l r = if c then mergeWithStrategy s l else mergeWithStrategy s r + mrgIfWithStrategy s cond l r = + mergeWithStrategy s $ unionIf cond l r + {-# INLINE mrgIfWithStrategy #-} + single = freshUAny . single + {-# INLINE single #-} + unionIf cond (UAny _ a) (UAny _ b) = freshUAny $ unionIf cond a b + unionIf cond (UMrg m a) (UAny _ b) = UMrg m $ ifWithStrategy m cond a b + unionIf cond a (UMrg m b) = UMrg m $ ifWithStrategy m cond (underlyingUnion a) b + {-# INLINE unionIf #-} + +instance (SEq a) => SEq (UnionM a) where + x ==~ y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 ==~ y1 + +-- | Lift the 'UnionM' to any 'MonadUnion'. +liftToMonadUnion :: (Mergeable a, MonadUnion u) => UnionM a -> u a +liftToMonadUnion u = go (underlyingUnion u) + where + go (Single v) = mrgSingle v + go (If _ _ c t f) = mrgIf c (go t) (go f) + +instance (SOrd a) => SOrd (UnionM a) where + x <=~ y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 <=~ y1 + x <~ y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 <~ y1 + x >=~ y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 >=~ y1 + x >~ y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 >~ y1 + x `symCompare` y = liftToMonadUnion $ do + x1 <- x + y1 <- y + x1 `symCompare` y1 + +instance {-# OVERLAPPABLE #-} (ToSym a b, Mergeable b) => ToSym a (UnionM b) where + toSym = mrgSingle . toSym + +instance {-# OVERLAPPING #-} (ToSym a b, Mergeable b) => ToSym (UnionM a) (UnionM b) where + toSym = merge . fmap toSym + +instance {-# OVERLAPPABLE #-} (ToCon a b) => ToCon (UnionM a) b where + toCon v = go $ underlyingUnion v + where + go (Single x) = toCon x + go _ = Nothing + +instance {-# OVERLAPPING #-} (ToCon a b, Mergeable b) => ToCon (UnionM a) (UnionM b) where + toCon v = go $ underlyingUnion v + where + go (Single x) = case toCon x of + Nothing -> Nothing + Just v -> Just $ mrgSingle v + go (If _ _ c t f) = do + t' <- go t + f' <- go f + return $ mrgIf c t' f' + +instance (Mergeable a, EvaluateSym a) => EvaluateSym (UnionM a) where + evaluateSym fillDefault model x = go $ underlyingUnion x + where + go :: Union a -> UnionM a + go (Single v) = mrgSingle $ evaluateSym fillDefault model v + go (If _ _ cond t f) = + mrgIf + (evaluateSym fillDefault model cond) + (go t) + (go f) + +instance (Mergeable a, SubstituteSym a) => SubstituteSym (UnionM a) where + substituteSym sym val x = go $ underlyingUnion x + where + go :: Union a -> UnionM a + go (Single v) = mrgSingle $ substituteSym sym val v + go (If _ _ cond t f) = + mrgIf + (substituteSym sym val cond) + (go t) + (go f) + +instance + (ExtractSymbolics a) => + ExtractSymbolics (UnionM a) + where + extractSymbolics v = go $ underlyingUnion v + where + go (Single x) = extractSymbolics x + go (If _ _ cond t f) = extractSymbolics cond <> go t <> go f + +instance (Hashable a) => Hashable (UnionM a) where + s `hashWithSalt` (UAny _ u) = s `hashWithSalt` (0 :: Int) `hashWithSalt` u + s `hashWithSalt` (UMrg _ u) = s `hashWithSalt` (1 :: Int) `hashWithSalt` u + +instance (Eq a) => Eq (UnionM a) where + UAny _ l == UAny _ r = l == r + UMrg _ l == UMrg _ r = l == r + _ == _ = False + +instance Eq1 UnionM where + liftEq e l r = liftEq e (underlyingUnion l) (underlyingUnion r) + +instance (Num a, Mergeable a) => Num (UnionM a) where + fromInteger = mrgSingle . fromInteger + negate x = x >>= (mrgSingle . negate) + x + y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 + y1 + x - y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 - y1 + x * y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 * y1 + abs x = x >>= mrgSingle . abs + signum x = x >>= mrgSingle . signum + +instance (ITEOp a, Mergeable a) => ITEOp (UnionM a) where + ites = mrgIf + +instance (LogicalOp a, Mergeable a) => LogicalOp (UnionM a) where + a ||~ b = do + a1 <- a + b1 <- b + mrgSingle $ a1 ||~ b1 + a &&~ b = do + a1 <- a + b1 <- b + mrgSingle $ a1 &&~ b1 + nots x = do + x1 <- x + mrgSingle $ nots x1 + xors a b = do + a1 <- a + b1 <- b + mrgSingle $ a1 `xors` b1 + implies a b = do + a1 <- a + b1 <- b + mrgSingle $ a1 `implies` b1 + +instance (Solvable c t, Mergeable t) => Solvable c (UnionM t) where + con = mrgSingle . con + {-# INLINE con #-} + ssym = mrgSingle . ssym + {-# INLINE ssym #-} + isym i s = mrgSingle $ isym i s + {-# INLINE isym #-} + sinfosym s info = mrgSingle $ sinfosym s info + {-# INLINE sinfosym #-} + iinfosym i s info = mrgSingle $ iinfosym i s info + {-# INLINE iinfosym #-} + conView v = do + c <- singleView v + conView c + {-# INLINE conView #-} + +instance + (Function f, Mergeable f, Mergeable a, Ret f ~ a) => + Function (UnionM f) + where + type Arg (UnionM f) = Arg f + type Ret (UnionM f) = UnionM (Ret f) + f # a = do + f1 <- f + mrgSingle $ f1 # a + +instance (IsString a, Mergeable a) => IsString (UnionM a) where + fromString = mrgSingle . fromString + +{- +foldMapUnion :: (Monoid m) => (a -> m) -> Union a -> m +foldMapUnion f (Single v) = f v +foldMapUnion f (If _ _ _ l r) = foldMapUnion f l <> foldMapUnion f r + +instance Foldable UnionM where + foldMap f u = foldMapUnion f (underlyingUnion u) + +sequenceAUnion :: (Applicative m, SymBoolOp bool) => Union (m a) -> m (Union a) +sequenceAUnion (Single v) = single <$> v +sequenceAUnion (If _ _ cond l r) = unionIf cond <$> sequenceAUnion l <*> sequenceAUnion r + +instance Traversable UnionM where + sequenceA u = freshUAny <$> sequenceAUnion (underlyingUnion u) + -} + +-- GenSym +instance (GenSym spec a, Mergeable a) => GenSym spec (UnionM a) + +instance (GenSym spec a) => GenSymSimple spec (UnionM a) where + simpleFresh spec = do + res <- fresh spec + if not (isMerged res) then error "Not merged" else return res + +instance + (GenSym a a, Mergeable a) => + GenSym (UnionM a) a + where + fresh spec = go (underlyingUnion $ merge spec) + where + go (Single x) = fresh x + go (If _ _ _ t f) = mrgIf <$> simpleFresh () <*> go t <*> go f + +-- Concrete Key HashMaps + +-- | Tag for concrete types. +-- Useful for specifying the merge strategy for some parametrized types where we should have different +-- merge strategy for symbolic and concrete ones. +class (Eq t, Ord t, Hashable t) => IsConcrete t + +instance IsConcrete Bool + +instance IsConcrete Integer + +instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (UnionM (Maybe t))) where + rootStrategy = SimpleStrategy mrgIte + +instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (UnionM (Maybe t))) where + mrgIte cond l r = + HML.unionWith (mrgIf cond) ul ur + where + ul = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + l + (HML.keys r) + ur = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + r + (HML.keys l) + +instance UnionWithExcept (UnionM (Either e v)) UnionM e v where + extractUnionExcept = id + +instance UnionWithExcept (UnionM (CBMCEither e v)) UnionM e v where + extractUnionExcept = fmap runCBMCEither diff --git a/src/Grisette/Core/Control/Monad/UnionM.hs-boot b/src/Grisette/Core/Control/Monad/UnionM.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Control/Monad/UnionM.hs-boot @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Grisette.Core.Control.Monad.UnionM (UnionM (..)) where + +import Data.IORef +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Union + +data UnionM a where + -- | 'UnionM' with no 'Mergeable' knowledge. + UAny :: + -- | (Possibly) cached merging result. + IORef (Either (Union a) (UnionM a)) -> + -- | Original 'Union'. + Union a -> + UnionM a + -- | 'UnionM' with 'Mergeable' knowledge. + UMrg :: + -- | Cached merging strategy. + MergingStrategy a -> + -- | Merged Union + Union a -> + UnionM a + +instance UnionLike UnionM + +instance Functor UnionM + +instance Applicative UnionM + +instance Monad UnionM diff --git a/src/Grisette/Core/Data/Class/BitVector.hs b/src/Grisette/Core/Data/Class/BitVector.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/BitVector.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Core.Data.Class.BitVector +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.BitVector + ( -- * Bit vector operations + BVConcat (..), + BVExtend (..), + BVSelect (..), + bvextract, + ) +where + +import Data.Proxy +import GHC.TypeNats + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Bitwise concatenation ('bvconcat') of the given bit vector values. +class BVConcat bv1 bv2 bv3 | bv1 bv2 -> bv3 where + -- | Bitwise concatenation of the given bit vector values. + -- + -- >>> bvconcat (0b101 :: SymIntN 3) (0b010 :: SymIntN 3) + -- 0b101010 + bvconcat :: bv1 -> bv2 -> bv3 + +-- | Bitwise extension of the given bit vector values. +class BVExtend bv1 (n :: Nat) bv2 | bv1 n -> bv2 where + -- | Bitwise zero extension of the given bit vector values. + -- + -- >>> bvzeroExtend (Proxy @6) (0b101 :: SymIntN 3) + -- 0b000101 + bvzeroExtend :: + -- | Desired output width + proxy n -> + -- | Bit vector to extend + bv1 -> + bv2 + + -- | Bitwise signed extension of the given bit vector values. + -- + -- >>> bvsignExtend (Proxy @6) (0b101 :: SymIntN 3) + -- 0b111101 + bvsignExtend :: + -- | Desired output width + proxy n -> + -- | Bit vector to extend + bv1 -> + bv2 + + -- | Bitwise extension of the given bit vector values. + -- Signedness is determined by the input bit vector type. + -- + -- >>> bvextend (Proxy @6) (0b101 :: SymIntN 3) + -- 0b111101 + -- >>> bvextend (Proxy @6) (0b001 :: SymIntN 3) + -- 0b000001 + -- >>> bvextend (Proxy @6) (0b101 :: SymWordN 3) + -- 0b000101 + -- >>> bvextend (Proxy @6) (0b001 :: SymWordN 3) + -- 0b000001 + bvextend :: + -- | Desired output width + proxy n -> + -- | Bit vector to extend + bv1 -> + bv2 + +-- | Slicing out a smaller bit vector from a larger one, selecting a slice with +-- width @w@ starting from index @ix@. +class BVSelect bv1 (ix :: Nat) (w :: Nat) bv2 | bv1 w -> bv2 where + -- | Slicing out a smaller bit vector from a larger one, selecting a slice with + -- width @w@ starting from index @ix@. + -- + -- The indices are counting from zero from the least significant bit. + -- + -- >>> bvselect (Proxy @1) (Proxy @3) (con 0b001010 :: SymIntN 6) + -- 0b101 + bvselect :: + -- | Index to start selecting from + proxy ix -> + -- | Desired output width, @0 <= ix@ and @ix + w < n@ must hold where @n@ is + -- the size of the input bit vector + proxy w -> + -- | Bit vector to select from + bv1 -> + bv2 + +-- | Extract a smaller bit vector from a larger one from bits @i@ down to @j@. +-- +-- The indices are counting from zero from the least significant bit. +-- >>> bvextract (Proxy @3) (Proxy @1) (con 0b001010 :: SymIntN 6) +-- 0b101 +bvextract :: + forall proxy i j bv1 bv2. + (BVSelect bv1 j (i - j + 1) bv2) => + -- | The start position to extract from, @0 <= i < n@ must hold where @n@ is + -- the size of the output bit vector + proxy i -> + -- | The end position to extract from, @0 <= j <= i@ must hold + proxy j -> + -- | Bit vector to extract from + bv1 -> + bv2 +bvextract _ _ = bvselect (Proxy @j) (Proxy @(i - j + 1)) +{-# INLINE bvextract #-} diff --git a/src/Grisette/Core/Data/Class/Bool.hs b/src/Grisette/Core/Data/Class/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Bool.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.Bool +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Bool + ( -- * Symbolic equality + SEq (..), + SEq' (..), + + -- * Symbolic Boolean operations + LogicalOp (..), + SymBoolOp, + ITEOp (..), + ) +where + +import Control.Monad.Except +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Word +import Generics.Deriving +import {-# SOURCE #-} Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Auxiliary class for 'SEq' instance derivation +class SEq' f where + -- | Auxiliary function for '(==~~) derivation + (==~~) :: f a -> f a -> SymBool + + infix 4 ==~~ + +instance SEq' U1 where + _ ==~~ _ = con True + {-# INLINE (==~~) #-} + +instance SEq' V1 where + _ ==~~ _ = con True + {-# INLINE (==~~) #-} + +instance SEq c => SEq' (K1 i c) where + (K1 a) ==~~ (K1 b) = a ==~ b + {-# INLINE (==~~) #-} + +instance SEq' a => SEq' (M1 i c a) where + (M1 a) ==~~ (M1 b) = a ==~~ b + {-# INLINE (==~~) #-} + +instance (SEq' a, SEq' b) => SEq' (a :+: b) where + (L1 a) ==~~ (L1 b) = a ==~~ b + (R1 a) ==~~ (R1 b) = a ==~~ b + _ ==~~ _ = con False + {-# INLINE (==~~) #-} + +instance (SEq' a, SEq' b) => SEq' (a :*: b) where + (a1 :*: b1) ==~~ (a2 :*: b2) = (a1 ==~~ a2) &&~ (b1 ==~~ b2) + {-# INLINE (==~~) #-} + +-- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a ==~ b +-- false +-- >>> a /=~ b +-- true +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a /=~ b +-- (! (= a b)) +-- >>> a /=~ b +-- (! (= a b)) +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SEq via (Default X) +class SEq a where + (==~) :: a -> a -> SymBool + a ==~ b = nots $ a /=~ b + {-# INLINE (==~) #-} + infix 4 ==~ + + (/=~) :: a -> a -> SymBool + a /=~ b = nots $ a ==~ b + {-# INLINE (/=~) #-} + infix 4 /=~ + {-# MINIMAL (==~) | (/=~) #-} + +instance (Generic a, SEq' (Rep a)) => SEq (Default a) where + Default l ==~ Default r = from l ==~~ from r + {-# INLINE (==~) #-} + +-- | Symbolic logical operators for symbolic booleans. +-- +-- >>> let t = con True :: SymBool +-- >>> let f = con False :: SymBool +-- >>> let a = "a" :: SymBool +-- >>> let b = "b" :: SymBool +-- >>> t ||~ f +-- true +-- >>> a ||~ t +-- true +-- >>> a ||~ f +-- a +-- >>> a ||~ b +-- (|| a b) +-- >>> t &&~ f +-- false +-- >>> a &&~ t +-- a +-- >>> a &&~ f +-- false +-- >>> a &&~ b +-- (&& a b) +-- >>> nots t +-- false +-- >>> nots f +-- true +-- >>> nots a +-- (! a) +-- >>> t `xors` f +-- true +-- >>> t `xors` t +-- false +-- >>> a `xors` t +-- (! a) +-- >>> a `xors` f +-- a +-- >>> a `xors` b +-- (|| (&& (! a) b) (&& a (! b))) +class LogicalOp b where + -- | Symbolic disjunction + (||~) :: b -> b -> b + a ||~ b = nots $ nots a &&~ nots b + {-# INLINE (||~) #-} + + infixr 2 ||~ + + -- | Symbolic conjunction + (&&~) :: b -> b -> b + a &&~ b = nots $ nots a ||~ nots b + {-# INLINE (&&~) #-} + + infixr 3 &&~ + + -- | Symbolic negation + nots :: b -> b + + -- | Symbolic exclusive disjunction + xors :: b -> b -> b + a `xors` b = (a &&~ nots b) ||~ (nots a &&~ b) + {-# INLINE xors #-} + + -- | Symbolic implication + implies :: b -> b -> b + a `implies` b = nots a ||~ b + {-# INLINE implies #-} + + {-# MINIMAL (||~), nots | (&&~), nots #-} + +instance LogicalOp Bool where + (||~) = (||) + {-# INLINE (||~) #-} + (&&~) = (&&) + {-# INLINE (&&~) #-} + nots = not + {-# INLINE nots #-} + +-- | ITE operator for solvable (see "Grisette.Core#solvable")s, including symbolic boolean, integer, etc. +-- +-- >>> let a = "a" :: SymBool +-- >>> let b = "b" :: SymBool +-- >>> let c = "c" :: SymBool +-- >>> ites a b c +-- (ite a b c) +class ITEOp v where + ites :: SymBool -> v -> v -> v + +-- | Aggregation for the operations on symbolic boolean types +class (SimpleMergeable b, SEq b, Eq b, LogicalOp b, Solvable Bool b, ITEOp b) => SymBoolOp b + +#define CONCRETE_SEQ(type) \ +instance SEq type where \ + l ==~ r = con $ l == r; \ + {-# INLINE (==~) #-} + +#if 1 +CONCRETE_SEQ(Bool) +CONCRETE_SEQ(Integer) +CONCRETE_SEQ(Char) +CONCRETE_SEQ(Int) +CONCRETE_SEQ(Int8) +CONCRETE_SEQ(Int16) +CONCRETE_SEQ(Int32) +CONCRETE_SEQ(Int64) +CONCRETE_SEQ(Word) +CONCRETE_SEQ(Word8) +CONCRETE_SEQ(Word16) +CONCRETE_SEQ(Word32) +CONCRETE_SEQ(Word64) +CONCRETE_SEQ(B.ByteString) +#endif + +-- List +deriving via (Default [a]) instance (SEq a) => SEq [a] + +-- Maybe +deriving via (Default (Maybe a)) instance (SEq a) => SEq (Maybe a) + +-- Either +deriving via (Default (Either e a)) instance (SEq e, SEq a) => SEq (Either e a) + +-- ExceptT +instance (SEq (m (Either e a))) => SEq (ExceptT e m a) where + (ExceptT a) ==~ (ExceptT b) = a ==~ b + {-# INLINE (==~) #-} + +-- MaybeT +instance (SEq (m (Maybe a))) => SEq (MaybeT m a) where + (MaybeT a) ==~ (MaybeT b) = a ==~ b + {-# INLINE (==~) #-} + +-- () +instance SEq () where + _ ==~ _ = con True + {-# INLINE (==~) #-} + +-- (,) +deriving via (Default (a, b)) instance (SEq a, SEq b) => SEq (a, b) + +-- (,,) +deriving via (Default (a, b, c)) instance (SEq a, SEq b, SEq c) => SEq (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + (SEq a, SEq b, SEq c, SEq d) => + SEq (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e) => + SEq (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f) => + SEq (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g) => + SEq (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g, SEq h) => + SEq (a, b, c, d, e, f, g, h) + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (SEq (f a), SEq (g a)) => SEq (Sum f g a) + +-- Writer +instance (SEq (m (a, s))) => SEq (WriterLazy.WriterT s m a) where + (WriterLazy.WriterT l) ==~ (WriterLazy.WriterT r) = l ==~ r + {-# INLINE (==~) #-} + +instance (SEq (m (a, s))) => SEq (WriterStrict.WriterT s m a) where + (WriterStrict.WriterT l) ==~ (WriterStrict.WriterT r) = l ==~ r + {-# INLINE (==~) #-} + +-- Identity +instance (SEq a) => SEq (Identity a) where + (Identity l) ==~ (Identity r) = l ==~ r + {-# INLINE (==~) #-} + +-- IdentityT +instance (SEq (m a)) => SEq (IdentityT m a) where + (IdentityT l) ==~ (IdentityT r) = l ==~ r + {-# INLINE (==~) #-} + +instance (SupportedPrim a) => ITEOp (Sym a) where + ites (Sym c) (Sym t) (Sym f) = Sym $ pevalITETerm c t f + +instance LogicalOp (Sym Bool) where + (Sym l) ||~ (Sym r) = Sym $ pevalOrTerm l r + (Sym l) &&~ (Sym r) = Sym $ pevalAndTerm l r + nots (Sym v) = Sym $ pevalNotTerm v + (Sym l) `xors` (Sym r) = Sym $ pevalXorTerm l r + (Sym l) `implies` (Sym r) = Sym $ pevalImplyTerm l r diff --git a/src/Grisette/Core/Data/Class/Bool.hs-boot b/src/Grisette/Core/Data/Class/Bool.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Bool.hs-boot @@ -0,0 +1,31 @@ +module Grisette.Core.Data.Class.Bool (LogicalOp (..)) where + +class LogicalOp b where + -- | Symbolic disjunction + (||~) :: b -> b -> b + a ||~ b = nots $ nots a &&~ nots b + {-# INLINE (||~) #-} + + infixr 2 ||~ + + -- | Symbolic conjunction + (&&~) :: b -> b -> b + a &&~ b = nots $ nots a ||~ nots b + {-# INLINE (&&~) #-} + + infixr 3 &&~ + + -- | Symbolic negation + nots :: b -> b + + -- | Symbolic exclusive disjunction + xors :: b -> b -> b + a `xors` b = (a &&~ nots b) ||~ (nots a &&~ b) + {-# INLINE xors #-} + + -- | Symbolic implication + implies :: b -> b -> b + a `implies` b = nots a ||~ b + {-# INLINE implies #-} + + {-# MINIMAL (||~), nots | (&&~), nots #-} diff --git a/src/Grisette/Core/Data/Class/CEGISSolver.hs b/src/Grisette/Core/Data/Class/CEGISSolver.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/CEGISSolver.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.Data.Class.CEGISSolver +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.CEGISSolver + ( -- * Note for the examples + + -- + + -- | The examples assumes a [z3](https://github.com/Z3Prover/z3) solver available in @PATH@. + + -- * CEGIS solver interfaces + CEGISSolver (..), + CEGISCondition (..), + cegisPostCond, + cegisPrePost, + cegis, + cegisExcept, + cegisExceptStdVC, + cegisExceptVC, + cegisExceptMultiInputs, + cegisExceptStdVCMultiInputs, + cegisExceptVCMultiInputs, + ) +where + +import GHC.Generics +import Generics.Deriving +import Grisette.Core.Control.Exception +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.Solver +import Grisette.IR.SymPrim.Data.Prim.Model +import Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.Lib.Base +-- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.Backend.SBV + +-- | The condition for CEGIS to solve. +-- +-- The first argument is the pre-condition, and the second argument is the +-- post-condition. +-- +-- The CEGIS procedures would try to find a model for the formula +-- +-- \[ +-- \forall P. (\exists I. \mathrm{pre}(P, I)) \wedge (\forall I. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I)) +-- \] +-- +-- In program synthesis tasks, \(P\) is the symbolic constants in the symbolic +-- program, and \(I\) is the input. The pre-condition is used to restrict the +-- search space of the program. The procedure would only return programs that +-- meets the pre-conditions on every possible inputs, and there are at least +-- one possible input. The post-condition is used to specify the desired program +-- behaviors. +data CEGISCondition = CEGISCondition SymBool SymBool deriving (Generic) + +-- | Construct a CEGIS condition with only a post-condition. The pre-condition +-- would be set to true, meaning that all programs in the program space are +-- allowed. +cegisPostCond :: SymBool -> CEGISCondition +cegisPostCond = CEGISCondition (con True) + +-- | Construct a CEGIS condition with both pre- and post-conditions. +cegisPrePost :: SymBool -> SymBool -> CEGISCondition +cegisPrePost = CEGISCondition + +deriving via (Default CEGISCondition) instance Mergeable CEGISCondition + +deriving via (Default CEGISCondition) instance SimpleMergeable CEGISCondition + +-- | Counter-example guided inductive synthesis (CEGIS) solver interface. +class + CEGISSolver config failure + | config -> failure + where + -- | + -- CEGIS with multiple (possibly symbolic) inputs. Solves the following formula (see + -- 'CEGISCondition' for details). + -- + -- \[ + -- \forall P. (\exists I\in\mathrm{inputs}. \mathrm{pre}(P, I)) \wedge (\forall I\in\mathrm{inputs}. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I)) + -- \] + -- + -- For simpler queries, where the inputs are representable by a single + -- symbolic value, you may want to use 'cegis' or 'cegisExcept' instead. + -- We have an example for the 'cegis' call. + cegisMultiInputs :: + (EvaluateSym inputs, ExtractSymbolics inputs) => + -- | The configuration of the solver + config -> + -- | Some initial counter-examples. Providing some concrete + -- inputs may help the solver to find a model faster. Providing + -- symbolic inputs would cause the solver to find the program + -- that works on all the inputs representable by it (see + -- 'CEGISCondition'). + [inputs] -> + -- | The function mapping the inputs to + -- the conditions for the solver to + -- solve. + (inputs -> CEGISCondition) -> + -- | The counter-examples generated + -- during the CEGIS loop, and the + -- model found by the solver. + IO (Either failure ([inputs], Model)) + +-- | +-- CEGIS with a single symbolic input to represent a set of inputs. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c >~ -2@ clause is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> cegis (UnboundedReasoning z3) x (cegisPrePost (x >~ 0) (x * c <~ 0 &&~ c >~ -2)) +-- Right ([],Model {c -> -1 :: Integer}) +cegis :: + ( CEGISSolver config failure, + EvaluateSym inputs, + ExtractSymbolics inputs + ) => + -- | The configuration of the solver + config -> + -- | Initial symbolic inputs. The solver will try to find a + -- program that works on all the inputs representable by it (see + -- 'CEGISCondition'). + inputs -> + -- | The condition for the solver to solve. All the + -- symbolic constants that are not in the inputs will + -- be considered as part of the symbolic program. + CEGISCondition -> + -- | The counter-examples generated + -- during the CEGIS loop, and the + -- model found by the solver. + IO (Either failure ([inputs], Model)) +cegis config inputs cond = cegisMultiInputs config [inputs] (const cond) + +-- | +-- CEGIS for symbolic programs with error handling, using multiple (possibly +-- symbolic) inputs to represent a set of inputs. +cegisExceptMultiInputs :: + ( CEGISSolver config failure, + EvaluateSym inputs, + ExtractSymbolics inputs, + UnionWithExcept t u e v, + UnionPrjOp u, + Monad u + ) => + config -> + [inputs] -> + (Either e v -> CEGISCondition) -> + (inputs -> t) -> + IO (Either failure ([inputs], Model)) +cegisExceptMultiInputs config cexes interpretFun f = + cegisMultiInputs config cexes (simpleMerge . (interpretFun <$>) . extractUnionExcept . f) + +-- | +-- CEGIS for symbolic programs with error handling, using multiple (possibly +-- symbolic) inputs to represent a set of inputs. +-- +-- The errors should be translated to assertion or assumption violations. +cegisExceptVCMultiInputs :: + ( CEGISSolver config failure, + EvaluateSym inputs, + ExtractSymbolics inputs, + UnionWithExcept t u e v, + UnionPrjOp u, + Monad u + ) => + config -> + [inputs] -> + (Either e v -> u (Either VerificationConditions ())) -> + (inputs -> t) -> + IO (Either failure ([inputs], Model)) +cegisExceptVCMultiInputs config cexes interpretFun f = + cegisMultiInputs + config + cexes + ( \v -> + simpleMerge + ( ( \case + Left AssumptionViolation -> cegisPrePost (con False) (con True) + Left AssertionViolation -> cegisPostCond (con False) + _ -> cegisPostCond (con True) + ) + <$> (extractUnionExcept (f v) >>= interpretFun) + ) + ) + +-- | +-- CEGIS for symbolic programs with error handling, using multiple (possibly +-- symbolic) inputs to represent a set of inputs. This function saves the +-- efforts to implement the translation function for the standard error type +-- 'VerificationConditions', and the standard result type '()'. +-- +-- This function translates assumption violations to failed pre-conditions, +-- and translates assertion violations to failed post-conditions. +-- The '()' result will not fail any conditions. +cegisExceptStdVCMultiInputs :: + ( CEGISSolver config failure, + EvaluateSym inputs, + ExtractSymbolics inputs, + UnionWithExcept t u VerificationConditions (), + UnionPrjOp u, + Monad u + ) => + config -> + [inputs] -> + (inputs -> t) -> + IO (Either failure ([inputs], Model)) +cegisExceptStdVCMultiInputs config cexes = + cegisExceptVCMultiInputs config cexes return + +-- | +-- CEGIS for symbolic programs with error handling, using a single symbolic +-- input to represent a set of inputs. +-- +-- 'cegisExcept' is particularly useful when custom error types are used. +-- With 'cegisExcept', you define how the errors are interpreted to the +-- CEGIS conditions after the symbolic evaluation. This could increase the +-- readability and modularity of the code. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c >~ -2@ assertion is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> import Control.Monad.Except +-- >>> :{ +-- res :: ExceptT VerificationConditions UnionM () +-- res = do +-- symAssume $ x >~ 0 +-- symAssert $ x * c <~ 0 +-- symAssert $ c >~ -2 +-- :} +-- +-- >>> :{ +-- translation (Left AssumptionViolation) = cegisPrePost (con False) (con True) +-- translation (Left AssertionViolation) = cegisPostCond (con False) +-- translation _ = cegisPostCond (con True) +-- :} +-- +-- >>> cegisExcept (UnboundedReasoning z3) x translation res +-- Right ([],Model {c -> -1 :: Integer}) +cegisExcept :: + ( UnionWithExcept t u e v, + UnionPrjOp u, + Functor u, + EvaluateSym inputs, + ExtractSymbolics inputs, + CEGISSolver config failure + ) => + config -> + inputs -> + (Either e v -> CEGISCondition) -> + t -> + IO (Either failure ([inputs], Model)) +cegisExcept config inputs f v = cegis config inputs $ simpleMerge $ f <$> extractUnionExcept v + +-- | +-- CEGIS for symbolic programs with error handling, using a single symbolic +-- input to represent a set of inputs. +-- +-- The errors should be translated to assertion or assumption violations. +cegisExceptVC :: + ( UnionWithExcept t u e v, + UnionPrjOp u, + Monad u, + EvaluateSym inputs, + ExtractSymbolics inputs, + CEGISSolver config failure + ) => + config -> + inputs -> + (Either e v -> u (Either VerificationConditions ())) -> + t -> + IO (Either failure ([inputs], Model)) +cegisExceptVC config inputs f v = + cegis config inputs $ + simpleMerge $ + ( \case + Left AssumptionViolation -> cegisPrePost (con False) (con True) + Left AssertionViolation -> cegisPostCond (con False) + _ -> cegisPostCond (con True) + ) + <$> (extractUnionExcept v >>= f) + +-- | +-- CEGIS for symbolic programs with error handling, using a single symbolic +-- input to represent a set of inputs. This function saves the efforts to +-- implement the translation function for the standard error type +-- 'VerificationConditions', and the standard result type '()'. +-- +-- This function translates assumption violations to failed pre-conditions, +-- and translates assertion violations to failed post-conditions. +-- The '()' result will not fail any conditions. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c >~ -2@ assertion is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> import Control.Monad.Except +-- >>> :{ +-- res :: ExceptT VerificationConditions UnionM () +-- res = do +-- symAssume $ x >~ 0 +-- symAssert $ x * c <~ 0 +-- symAssert $ c >~ -2 +-- :} +-- +-- >>> cegisExceptStdVC (UnboundedReasoning z3) x res +-- Right ([],Model {c -> -1 :: Integer}) +cegisExceptStdVC :: + ( UnionWithExcept t u VerificationConditions (), + UnionPrjOp u, + Monad u, + EvaluateSym inputs, + ExtractSymbolics inputs, + CEGISSolver config failure + ) => + config -> + inputs -> + t -> + IO (Either failure ([inputs], Model)) +cegisExceptStdVC config inputs = cegisExceptVC config inputs return diff --git a/src/Grisette/Core/Data/Class/Error.hs b/src/Grisette/Core/Data/Class/Error.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Error.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.Data.Class.Error +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Error + ( -- * Error transformation + TransformError (..), + + -- * Throwing error + symAssertTransformableError, + symThrowTransformableError, + ) +where + +import Control.Monad.Except +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Control.Exception +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XOverloadedStrings +-- >>> :set -XFlexibleContexts + +-- | This class indicates that the error type @to@ can always represent the +-- error type @from@. +-- +-- This is useful in implementing generic procedures that may throw errors. +-- For example, we support symbolic division and modulo operations. These +-- operations should throw an error when the divisor is zero, and we use the +-- standard error type 'Control.Exception.ArithException' for this purpose. +-- However, the user may use other type to represent errors, so we need this +-- type class to transform the 'Control.Exception.ArithException' to the +-- user-defined types. +-- +-- Another example of these generic procedures is the +-- 'Grisette.Core.symAssert' and 'Grisette.Core.symAssume' functions. +-- They can be used with any error types that are +-- compatible with the 'Grisette.Core.AssertionError' and +-- 'Grisette.Core.VerificationConditions' types, respectively. +class TransformError from to where + -- | Transforms an error with type @from@ to an error with type @to@. + transformError :: from -> to + +instance {-# OVERLAPPABLE #-} TransformError a a where + transformError = id + {-# INLINE transformError #-} + +instance {-# OVERLAPS #-} TransformError a () where + transformError _ = () + {-# INLINE transformError #-} + +instance {-# OVERLAPPING #-} TransformError () () where + transformError _ = () + {-# INLINE transformError #-} + +-- | Used within a monadic multi path computation to begin exception processing. +-- +-- Terminate the current execution path with the specified error. Compatible +-- errors can be transformed. +-- +-- >>> symThrowTransformableError Overflow :: ExceptT AssertionError UnionM () +-- ExceptT {Left AssertionError} +symThrowTransformableError :: + ( Mergeable to, + Mergeable a, + TransformError from to, + MonadError to erm, + MonadUnion erm + ) => + from -> + erm a +symThrowTransformableError = merge . throwError . transformError +{-# INLINE symThrowTransformableError #-} + +-- | Used within a monadic multi path computation for exception processing. +-- +-- Terminate the current execution path with the specified error if the condition does not hold. +-- Compatible error can be transformed. +-- +-- >>> let assert = symAssertTransformableError AssertionError +-- >>> assert "a" :: ExceptT AssertionError UnionM () +-- ExceptT {If (! a) (Left AssertionError) (Right ())} +symAssertTransformableError :: + ( Mergeable to, + TransformError from to, + MonadError to erm, + MonadUnion erm + ) => + from -> + SymBool -> + erm () +symAssertTransformableError err cond = mrgIf cond (return ()) (symThrowTransformableError err) +{-# INLINE symAssertTransformableError #-} diff --git a/src/Grisette/Core/Data/Class/Evaluate.hs b/src/Grisette/Core/Data/Class/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Evaluate.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.Evaluate +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Evaluate + ( -- * Evaluating symbolic values with model + EvaluateSym (..), + evaluateSymToCon, + ) +where + +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Maybe +import Data.Word +import Generics.Deriving +import Generics.Deriving.Instances () +import Grisette.Core.Data.Class.ModelOps +import Grisette.Core.Data.Class.ToCon +import Grisette.IR.SymPrim.Data.Prim.Model + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> import Data.Proxy +-- >>> :set -XTypeApplications + +-- | Evaluating symbolic values with some model. +-- +-- >>> let model = insertValue (SimpleSymbol "a") (1 :: Integer) emptyModel :: Model +-- >>> evaluateSym False model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,b] +-- +-- If we set the first argument true, the missing variables will be filled in with +-- some default values: +-- +-- >>> evaluateSym True model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,0] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving EvaluateSym via (Default X) +class EvaluateSym a where + -- | Evaluate a symbolic variable with some model, possibly fill in values for the missing variables. + evaluateSym :: Bool -> Model -> a -> a + +instance (Generic a, EvaluateSym' (Rep a)) => EvaluateSym (Default a) where + evaluateSym fillDefault model = Default . to . evaluateSym' fillDefault model . from . unDefault + +class EvaluateSym' a where + evaluateSym' :: Bool -> Model -> a c -> a c + +instance EvaluateSym' U1 where + evaluateSym' _ _ = id + +instance EvaluateSym c => EvaluateSym' (K1 i c) where + evaluateSym' fillDefault model (K1 v) = K1 $ evaluateSym fillDefault model v + +instance EvaluateSym' a => EvaluateSym' (M1 i c a) where + evaluateSym' fillDefault model (M1 v) = M1 $ evaluateSym' fillDefault model v + +instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :+: b) where + evaluateSym' fillDefault model (L1 l) = L1 $ evaluateSym' fillDefault model l + evaluateSym' fillDefault model (R1 r) = R1 $ evaluateSym' fillDefault model r + +instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :*: b) where + evaluateSym' fillDefault model (a :*: b) = evaluateSym' fillDefault model a :*: evaluateSym' fillDefault model b + +-- | Evaluate a symbolic variable with some model, fill in values for the missing variables, +-- and transform to concrete ones +-- +-- >>> let model = insertValue (SimpleSymbol "a") (1 :: Integer) emptyModel :: Model +-- >>> evaluateSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] +-- [1,0] +evaluateSymToCon :: (ToCon a b, EvaluateSym a) => Model -> a -> b +evaluateSymToCon model a = fromJust $ toCon $ evaluateSym True model a + +-- instances + +#define CONCRETE_EVALUATESYM(type) \ +instance EvaluateSym type where \ + evaluateSym _ _ = id + +#if 1 +CONCRETE_EVALUATESYM(Bool) +CONCRETE_EVALUATESYM(Integer) +CONCRETE_EVALUATESYM(Char) +CONCRETE_EVALUATESYM(Int) +CONCRETE_EVALUATESYM(Int8) +CONCRETE_EVALUATESYM(Int16) +CONCRETE_EVALUATESYM(Int32) +CONCRETE_EVALUATESYM(Int64) +CONCRETE_EVALUATESYM(Word) +CONCRETE_EVALUATESYM(Word8) +CONCRETE_EVALUATESYM(Word16) +CONCRETE_EVALUATESYM(Word32) +CONCRETE_EVALUATESYM(Word64) +CONCRETE_EVALUATESYM(B.ByteString) +#endif + +-- () +instance EvaluateSym () where + evaluateSym _ _ = id + +-- Either +deriving via (Default (Either a b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (Either a b) + +-- Maybe +deriving via (Default (Maybe a)) instance (EvaluateSym a) => EvaluateSym (Maybe a) + +-- List +deriving via (Default [a]) instance (EvaluateSym a) => EvaluateSym [a] + +-- (,) +deriving via (Default (a, b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (a, b) + +-- (,,) +deriving via (Default (a, b, c)) instance (EvaluateSym a, EvaluateSym b, EvaluateSym c) => EvaluateSym (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d) => EvaluateSym (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e) => + EvaluateSym (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e, EvaluateSym f) => + EvaluateSym (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( EvaluateSym a, + EvaluateSym b, + EvaluateSym c, + EvaluateSym d, + EvaluateSym e, + EvaluateSym f, + EvaluateSym g + ) => + EvaluateSym (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( EvaluateSym a, + EvaluateSym b, + EvaluateSym c, + EvaluateSym d, + EvaluateSym e, + EvaluateSym f, + EvaluateSym g, + EvaluateSym h + ) => + EvaluateSym ((,,,,,,,) a b c d e f g h) + +-- MaybeT +instance (EvaluateSym (m (Maybe a))) => EvaluateSym (MaybeT m a) where + evaluateSym fillDefault model (MaybeT v) = MaybeT $ evaluateSym fillDefault model v + +-- ExceptT +instance (EvaluateSym (m (Either e a))) => EvaluateSym (ExceptT e m a) where + evaluateSym fillDefault model (ExceptT v) = ExceptT $ evaluateSym fillDefault model v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (EvaluateSym (f a), EvaluateSym (g a)) => EvaluateSym (Sum f g a) + +-- WriterT +instance EvaluateSym (m (a, s)) => EvaluateSym (WriterLazy.WriterT s m a) where + evaluateSym fillDefault model (WriterLazy.WriterT v) = WriterLazy.WriterT $ evaluateSym fillDefault model v + +instance EvaluateSym (m (a, s)) => EvaluateSym (WriterStrict.WriterT s m a) where + evaluateSym fillDefault model (WriterStrict.WriterT v) = WriterStrict.WriterT $ evaluateSym fillDefault model v + +-- Identity +instance EvaluateSym a => EvaluateSym (Identity a) where + evaluateSym fillDefault model (Identity a) = Identity $ evaluateSym fillDefault model a + +-- IdentityT +instance EvaluateSym (m a) => EvaluateSym (IdentityT m a) where + evaluateSym fillDefault model (IdentityT a) = IdentityT $ evaluateSym fillDefault model a diff --git a/src/Grisette/Core/Data/Class/ExtractSymbolics.hs b/src/Grisette/Core/Data/Class/ExtractSymbolics.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/ExtractSymbolics.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.ExtractSymbolics +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.ExtractSymbolics + ( -- * Extracting symbolic constant set from a value + ExtractSymbolics (..), + ) +where + +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Word +import Generics.Deriving +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.Model + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.Lib.Base +-- >>> import Data.HashSet as HashSet +-- >>> import Data.List (sort) + +-- | Extracts all the symbolic variables that are transitively contained in the given value. +-- +-- >>> extractSymbolics ("a" :: SymBool) :: SymbolSet +-- SymbolSet {a :: Bool} +-- +-- >>> extractSymbolics (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: UnionM [SymBool]) :: SymbolSet +-- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving ExtractSymbolics via (Default X) +class ExtractSymbolics a where + extractSymbolics :: a -> SymbolSet + +instance (Generic a, ExtractSymbolics' (Rep a)) => ExtractSymbolics (Default a) where + extractSymbolics = extractSymbolics' . from . unDefault + +class ExtractSymbolics' a where + extractSymbolics' :: a c -> SymbolSet + +instance ExtractSymbolics' U1 where + extractSymbolics' _ = mempty + +instance (ExtractSymbolics c) => ExtractSymbolics' (K1 i c) where + extractSymbolics' = extractSymbolics . unK1 + +instance (ExtractSymbolics' a) => ExtractSymbolics' (M1 i c a) where + extractSymbolics' = extractSymbolics' . unM1 + +instance + (ExtractSymbolics' a, ExtractSymbolics' b) => + ExtractSymbolics' (a :+: b) + where + extractSymbolics' (L1 l) = extractSymbolics' l + extractSymbolics' (R1 r) = extractSymbolics' r + +instance + (ExtractSymbolics' a, ExtractSymbolics' b) => + ExtractSymbolics' (a :*: b) + where + extractSymbolics' (l :*: r) = extractSymbolics' l <> extractSymbolics' r + +-- instances + +#define CONCRETE_EXTRACT_SYMBOLICS(type) \ +instance ExtractSymbolics type where \ + extractSymbolics _ = mempty + +#if 1 +CONCRETE_EXTRACT_SYMBOLICS(Bool) +CONCRETE_EXTRACT_SYMBOLICS(Integer) +CONCRETE_EXTRACT_SYMBOLICS(Char) +CONCRETE_EXTRACT_SYMBOLICS(Int) +CONCRETE_EXTRACT_SYMBOLICS(Int8) +CONCRETE_EXTRACT_SYMBOLICS(Int16) +CONCRETE_EXTRACT_SYMBOLICS(Int32) +CONCRETE_EXTRACT_SYMBOLICS(Int64) +CONCRETE_EXTRACT_SYMBOLICS(Word) +CONCRETE_EXTRACT_SYMBOLICS(Word8) +CONCRETE_EXTRACT_SYMBOLICS(Word16) +CONCRETE_EXTRACT_SYMBOLICS(Word32) +CONCRETE_EXTRACT_SYMBOLICS(Word64) +CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) +#endif + +-- () +instance ExtractSymbolics () where + extractSymbolics _ = mempty + +-- Either +deriving via + (Default (Either a b)) + instance + (ExtractSymbolics a, ExtractSymbolics b) => + ExtractSymbolics (Either a b) + +-- Maybe +deriving via + (Default (Maybe a)) + instance + (ExtractSymbolics a) => ExtractSymbolics (Maybe a) + +-- List +deriving via + (Default [a]) + instance + (ExtractSymbolics a) => ExtractSymbolics [a] + +-- (,) +deriving via + (Default (a, b)) + instance + (ExtractSymbolics a, ExtractSymbolics b) => + ExtractSymbolics (a, b) + +-- (,,) +deriving via + (Default (a, b, c)) + instance + (ExtractSymbolics a, ExtractSymbolics b, ExtractSymbolics c) => + ExtractSymbolics (a, b, c) + +-- MaybeT +instance (ExtractSymbolics (m (Maybe a))) => ExtractSymbolics (MaybeT m a) where + extractSymbolics (MaybeT v) = extractSymbolics v + +-- ExceptT +instance + (ExtractSymbolics (m (Either e a))) => + ExtractSymbolics (ExceptT e m a) + where + extractSymbolics (ExceptT v) = extractSymbolics v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (ExtractSymbolics (f a), ExtractSymbolics (g a)) => + ExtractSymbolics (Sum f g a) + +-- WriterT +instance + (ExtractSymbolics (m (a, s))) => + ExtractSymbolics (WriterLazy.WriterT s m a) + where + extractSymbolics (WriterLazy.WriterT f) = extractSymbolics f + +instance + (ExtractSymbolics (m (a, s))) => + ExtractSymbolics (WriterStrict.WriterT s m a) + where + extractSymbolics (WriterStrict.WriterT f) = extractSymbolics f + +-- Identity +instance (ExtractSymbolics a) => ExtractSymbolics (Identity a) where + extractSymbolics (Identity a) = extractSymbolics a + +-- IdentityT +instance (ExtractSymbolics (m a)) => ExtractSymbolics (IdentityT m a) where + extractSymbolics (IdentityT a) = extractSymbolics a diff --git a/src/Grisette/Core/Data/Class/Function.hs b/src/Grisette/Core/Data/Class/Function.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Function.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Core.Data.Class.Function +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Function + ( -- * Function operations + Function (..), + ) +where + +-- | Abstraction for function-like types. +class Function f where + -- | Argument type + type Arg f + + -- | Return type + type Ret f + + -- | Function application operator. + -- + -- The operator is not right associated (like `($)`). It is left associated, + -- and you can provide many arguments with this operator once at a time. + -- + -- >>> (+1) # 2 + -- 3 + -- + -- >>> (+) # 2 # 3 + -- 5 + (#) :: f -> Arg f -> Ret f + + infixl 9 # + +instance Function (a -> b) where + type Arg (a -> b) = a + type Ret (a -> b) = b + f # a = f a diff --git a/src/Grisette/Core/Data/Class/GenSym.hs b/src/Grisette/Core/Data/Class/GenSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/GenSym.hs @@ -0,0 +1,1474 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.GenSym +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.GenSym + ( -- * Indices and identifiers for fresh symbolic value generation + FreshIndex (..), + FreshIdent (..), + name, + nameWithInfo, + + -- * Monad for fresh symbolic value generation + MonadFresh (..), + FreshT, + Fresh, + runFreshT, + runFresh, + + -- * Symbolic value generation + GenSym (..), + GenSymSimple (..), + genSym, + genSymSimple, + derivedNoSpecFresh, + derivedNoSpecSimpleFresh, + derivedSameShapeSimpleFresh, + + -- * Symbolic choices + chooseFresh, + chooseSimpleFresh, + chooseUnionFresh, + choose, + chooseSimple, + chooseUnion, + + -- * Some common GenSym specifications + ListSpec (..), + SimpleListSpec (..), + EnumGenBound (..), + EnumGenUpperBound (..), + ) +where + +import Control.DeepSeq +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Signatures +import Control.Monad.Trans.Maybe +import Data.Bifunctor +import qualified Data.ByteString as B +import Data.Hashable +import Data.Int +import Data.String +import Data.Typeable +import Data.Word +import Generics.Deriving hiding (index) +import Grisette.Core.Control.Monad.Union +import {-# SOURCE #-} Grisette.Core.Control.Monad.UnionM +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim +import Language.Haskell.TH.Syntax hiding (lift) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications + +-- | Index type used for 'GenSym'. +-- +-- To generate fresh variables, a monadic stateful context will be maintained. +-- The index should be increased every time a new symbolic constant is +-- generated. +newtype FreshIndex = FreshIndex Int + deriving (Show) + deriving (Eq, Ord, Num) via Int + +instance Mergeable FreshIndex where + rootStrategy = SimpleStrategy $ \_ t f -> max t f + +instance SimpleMergeable FreshIndex where + mrgIte _ = max + +-- | Identifier type used for 'GenSym' +-- +-- The constructor is hidden intentionally. +-- You can construct an identifier by: +-- +-- * a raw name +-- +-- The following two expressions will refer to the same identifier (the +-- solver won't distinguish them and would assign the same value to them). +-- The user may need to use unique names to avoid unintentional identifier +-- collision. +-- +-- >>> name "a" +-- a +-- +-- >>> "a" :: FreshIdent -- available when OverloadedStrings is enabled +-- a +-- +-- * bundle the calling file location with the name to ensure global uniqueness +-- +-- Identifiers created at different locations will not be the +-- same. The identifiers created at the same location will be the same. +-- +-- >>> $$(nameWithLoc "a") -- a sample result could be "a::18:4-18" +-- a::... +-- +-- * bundle the calling file location with some user provided information +-- +-- Identifiers created with different name or different additional +-- information will not be the same. +-- +-- >>> nameWithInfo "a" (1 :: Int) +-- a:1 +data FreshIdent where + FreshIdent :: String -> FreshIdent + FreshIdentWithInfo :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => String -> a -> FreshIdent + +instance Show FreshIdent where + show (FreshIdent i) = i + show (FreshIdentWithInfo s i) = s ++ ":" ++ show i + +instance IsString FreshIdent where + fromString = name + +instance Eq FreshIdent where + FreshIdent l == FreshIdent r = l == r + FreshIdentWithInfo l (linfo :: linfo) == FreshIdentWithInfo r (rinfo :: rinfo) = case eqT @linfo @rinfo of + Just Refl -> l == r && linfo == rinfo + _ -> False + _ == _ = False + +instance Ord FreshIdent where + FreshIdent l <= FreshIdent r = l <= r + FreshIdent _ <= _ = True + _ <= FreshIdent _ = False + FreshIdentWithInfo l (linfo :: linfo) <= FreshIdentWithInfo r (rinfo :: rinfo) = + l < r + || ( l == r + && ( case eqT @linfo @rinfo of + Just Refl -> linfo <= rinfo + _ -> typeRep (Proxy @linfo) <= typeRep (Proxy @rinfo) + ) + ) + +instance Hashable FreshIdent where + hashWithSalt s (FreshIdent n) = s `hashWithSalt` n + hashWithSalt s (FreshIdentWithInfo n i) = s `hashWithSalt` n `hashWithSalt` i + +instance Lift FreshIdent where + liftTyped (FreshIdent n) = [||FreshIdent n||] + liftTyped (FreshIdentWithInfo n i) = [||FreshIdentWithInfo n i||] + +instance NFData FreshIdent where + rnf (FreshIdent n) = rnf n + rnf (FreshIdentWithInfo n i) = rnf n `seq` rnf i + +-- | Simple name identifier. +-- The same identifier refers to the same symbolic variable in the whole program. +-- +-- The user may need to use unique names to avoid unintentional identifier +-- collision. +name :: String -> FreshIdent +name = FreshIdent + +-- | Identifier with extra information. +-- The same name with the same information +-- refers to the same symbolic variable in the whole program. +-- +-- The user may need to use unique names or additional information to avoid +-- unintentional identifier collision. +nameWithInfo :: forall a. (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => String -> a -> FreshIdent +nameWithInfo = FreshIdentWithInfo + +-- | Monad class for fresh symbolic value generation. +-- +-- The monad should be a reader monad for the 'FreshIdent' and a state monad for +-- the 'FreshIndex'. +class Monad m => MonadFresh m where + -- | Increase the index by one and return the new index. + nextFreshIndex :: m FreshIndex + + -- | Get the identifier. + getFreshIdent :: m FreshIdent + +-- | A symbolic generation monad transformer. +-- It is a reader monad transformer for identifiers and +-- a state monad transformer for indices. +-- +-- Each time a fresh symbolic variable is generated, the index should be increased. +newtype FreshT m a = FreshT {runFreshT' :: FreshIdent -> FreshIndex -> m (a, FreshIndex)} + +instance + (Mergeable a, Mergeable1 m) => + Mergeable (FreshT m a) + where + rootStrategy = + wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) FreshT runFreshT' + +instance (Mergeable1 m) => Mergeable1 (FreshT m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy)))) + FreshT + runFreshT' + +instance + (UnionLike m, Mergeable a) => + SimpleMergeable (FreshT m a) + where + mrgIte = mrgIf + +instance + (UnionLike m) => + SimpleMergeable1 (FreshT m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + +instance + (UnionLike m) => + UnionLike (FreshT m) + where + mergeWithStrategy s (FreshT f) = + FreshT $ \ident index -> mergeWithStrategy (liftRootStrategy2 s rootStrategy) $ f ident index + mrgIfWithStrategy s cond (FreshT t) (FreshT f) = + FreshT $ \ident index -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t ident index) (f ident index) + single x = FreshT $ \_ i -> single (x, i) + unionIf cond (FreshT t) (FreshT f) = + FreshT $ \ident index -> unionIf cond (t ident index) (f ident index) + +-- | Run the symbolic generation with the given identifier and 0 as the initial index. +runFreshT :: (Monad m) => FreshT m a -> FreshIdent -> m a +runFreshT m ident = fst <$> runFreshT' m ident (FreshIndex 0) + +instance (Functor f) => Functor (FreshT f) where + fmap f (FreshT s) = FreshT $ \ident idx -> first f <$> s ident idx + +instance (Applicative m, Monad m) => Applicative (FreshT m) where + pure a = FreshT $ \_ idx -> pure (a, idx) + FreshT fs <*> FreshT as = FreshT $ \ident idx -> do + (f, idx') <- fs ident idx + (a, idx'') <- as ident idx' + return (f a, idx'') + +instance (Monad m) => Monad (FreshT m) where + (FreshT s) >>= f = FreshT $ \ident idx -> do + (a, idx') <- s ident idx + runFreshT' (f a) ident idx' + +instance MonadTrans FreshT where + lift x = FreshT $ \_ index -> (,index) <$> x + +liftFreshTCache :: (Functor m) => Catch e m (a, FreshIndex) -> Catch e (FreshT m) a +liftFreshTCache catchE (FreshT m) h = + FreshT $ \ident index -> m ident index `catchE` \e -> runFreshT' (h e) ident index + +instance (MonadError e m) => MonadError e (FreshT m) where + throwError = lift . throwError + catchError = liftFreshTCache catchError + +-- | 'FreshT' specialized with Identity. +type Fresh = FreshT Identity + +-- | Run the symbolic generation with the given identifier and 0 as the initial index. +runFresh :: Fresh a -> FreshIdent -> a +runFresh m ident = runIdentity $ runFreshT m ident + +instance Monad m => MonadFresh (FreshT m) where + nextFreshIndex = FreshT $ \_ idx -> return (idx, idx + 1) + getFreshIdent = FreshT $ curry return + +-- | Class of types in which symbolic values can be generated with respect to some specification. +-- +-- The result will be wrapped in a union-like monad. +-- This ensures that we can generate those types with complex merging rules. +-- +-- The uniqueness of symbolic constants is managed with the a monadic context. +-- 'Fresh' and 'FreshT' can be useful. +class (Mergeable a) => GenSym spec a where + -- | Generate a symbolic value given some specification. Within a single + -- `MonadFresh` context, calls to `fresh` would generate unique symbolic + -- constants. + -- + -- The following example generates a symbolic boolean. No specification is + -- needed. + -- + -- >>> runFresh (fresh ()) "a" :: UnionM SymBool + -- {a@0} + -- + -- The following example generates booleans, which cannot be merged into a + -- single value with type 'Bool'. No specification is needed. + -- + -- >>> runFresh (fresh ()) "a" :: UnionM Bool + -- {If a@0 False True} + -- + -- The following example generates @Maybe Bool@s. + -- There are more than one symbolic constants introduced, and their uniqueness + -- is ensured. No specification is needed. + -- + -- >>> runFresh (fresh ()) "a" :: UnionM (Maybe Bool) + -- {If a@0 Nothing (If a@1 (Just False) (Just True))} + -- + -- The following example generates lists of symbolic booleans with length 1 to 2. + -- + -- >>> runFresh (fresh (ListSpec 1 2 ())) "a" :: UnionM [SymBool] + -- {If a@2 [a@1] [a@0,a@1]} + -- + -- When multiple symbolic values are generated, there will not be any + -- identifier collision + -- + -- >>> runFresh (do; a <- fresh (); b <- fresh (); return (a, b)) "a" :: (UnionM SymBool, UnionM SymBool) + -- ({a@0},{a@1}) + fresh :: + (MonadFresh m) => + spec -> + m (UnionM a) + default fresh :: + (GenSymSimple spec a) => + ( MonadFresh m + ) => + spec -> + m (UnionM a) + fresh spec = mrgSingle <$> simpleFresh spec + +-- | Generate a symbolic variable wrapped in a Union without the monadic context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +-- +-- >>> genSym (ListSpec 1 2 ()) "a" :: UnionM [SymBool] +-- {If a@2 [a@1] [a@0,a@1]} +genSym :: (GenSym spec a) => spec -> FreshIdent -> UnionM a +genSym = runFresh . fresh + +-- | Class of types in which symbolic values can be generated with respect to some specification. +-- +-- The result will __/not/__ be wrapped in a union-like monad. +-- +-- The uniqueness of symbolic constants is managed with the a monadic context. +-- 'Fresh' and 'FreshT' can be useful. +class GenSymSimple spec a where + -- | Generate a symbolic value given some specification. The uniqueness is ensured. + -- + -- The following example generates a symbolic boolean. No specification is needed. + -- + -- >>> runFresh (simpleFresh ()) "a" :: SymBool + -- a@0 + -- + -- The following code generates list of symbolic boolean with length 2. + -- As the length is fixed, we don't have to wrap the result in unions. + -- + -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "a" :: [SymBool] + -- [a@0,a@1] + simpleFresh :: + ( MonadFresh m + ) => + spec -> + m a + +-- | Generate a simple symbolic variable wrapped in a Union without the monadic context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +-- +-- >>> genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool] +-- [a@0,a@1] +genSymSimple :: forall spec a. (GenSymSimple spec a) => spec -> FreshIdent -> a +genSymSimple = runFresh . simpleFresh + +class GenSymNoSpec a where + freshNoSpec :: + ( MonadFresh m + ) => + m (UnionM (a c)) + +instance GenSymNoSpec U1 where + freshNoSpec = return $ mrgSingle U1 + +instance (GenSym () c) => GenSymNoSpec (K1 i c) where + freshNoSpec = fmap K1 <$> fresh () + +instance (GenSymNoSpec a) => GenSymNoSpec (M1 i c a) where + freshNoSpec = fmap M1 <$> freshNoSpec + +instance + ( GenSymNoSpec a, + GenSymNoSpec b, + forall x. Mergeable (a x), + forall x. Mergeable (b x) + ) => + GenSymNoSpec (a :+: b) + where + freshNoSpec :: + forall m u c. + ( MonadFresh m + ) => + m (UnionM ((a :+: b) c)) + freshNoSpec = do + cond :: bool <- simpleFresh () + l :: UnionM (a c) <- freshNoSpec + r :: UnionM (b c) <- freshNoSpec + return $ mrgIf cond (fmap L1 l) (fmap R1 r) + +instance + (GenSymNoSpec a, GenSymNoSpec b) => + GenSymNoSpec (a :*: b) + where + freshNoSpec :: + forall m u c. + ( MonadFresh m + ) => + m (UnionM ((a :*: b) c)) + freshNoSpec = do + l :: UnionM (a c) <- freshNoSpec + r :: UnionM (b c) <- freshNoSpec + return $ do + l1 <- l + r1 <- r + return $ l1 :*: r1 + +-- | We cannot provide DerivingVia style derivation for 'GenSym', while you can +-- use this 'fresh' implementation to implement 'GenSym' for your own types. +-- +-- This 'fresh' implementation is for the types that does not need any specification. +-- It will generate product types by generating each fields with '()' as specification, +-- and generate all possible values for a sum type. +-- +-- __Note:__ __Never__ use on recursive types. +derivedNoSpecFresh :: + forall bool a m u. + ( Generic a, + GenSymNoSpec (Rep a), + Mergeable a, + MonadFresh m + ) => + () -> + m (UnionM a) +derivedNoSpecFresh _ = merge . fmap to <$> freshNoSpec + +class GenSymSimpleNoSpec a where + simpleFreshNoSpec :: (MonadFresh m) => m (a c) + +instance GenSymSimpleNoSpec U1 where + simpleFreshNoSpec = return U1 + +instance (GenSymSimple () c) => GenSymSimpleNoSpec (K1 i c) where + simpleFreshNoSpec = K1 <$> simpleFresh () + +instance (GenSymSimpleNoSpec a) => GenSymSimpleNoSpec (M1 i c a) where + simpleFreshNoSpec = M1 <$> simpleFreshNoSpec + +instance + (GenSymSimpleNoSpec a, GenSymSimpleNoSpec b) => + GenSymSimpleNoSpec (a :*: b) + where + simpleFreshNoSpec = do + l :: a c <- simpleFreshNoSpec + r :: b c <- simpleFreshNoSpec + return $ l :*: r + +-- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while +-- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo +-- your own types. +-- +-- This 'simpleFresh' implementation is for the types that does not need any specification. +-- It will generate product types by generating each fields with '()' as specification. +-- It will not work on sum types. +-- +-- __Note:__ __Never__ use on recursive types. +derivedNoSpecSimpleFresh :: + forall a m. + ( Generic a, + GenSymSimpleNoSpec (Rep a), + MonadFresh m + ) => + () -> + m a +derivedNoSpecSimpleFresh _ = to <$> simpleFreshNoSpec + +class GenSymSameShape a where + genSymSameShapeFresh :: + ( MonadFresh m + ) => + a c -> + m (a c) + +instance GenSymSameShape U1 where + genSymSameShapeFresh _ = return U1 + +instance (GenSymSimple c c) => GenSymSameShape (K1 i c) where + genSymSameShapeFresh (K1 c) = K1 <$> simpleFresh c + +instance (GenSymSameShape a) => GenSymSameShape (M1 i c a) where + genSymSameShapeFresh (M1 a) = M1 <$> genSymSameShapeFresh a + +instance + (GenSymSameShape a, GenSymSameShape b) => + GenSymSameShape (a :+: b) + where + genSymSameShapeFresh (L1 a) = L1 <$> genSymSameShapeFresh a + genSymSameShapeFresh (R1 a) = R1 <$> genSymSameShapeFresh a + +instance + (GenSymSameShape a, GenSymSameShape b) => + GenSymSameShape (a :*: b) + where + genSymSameShapeFresh (a :*: b) = do + l :: a c <- genSymSameShapeFresh a + r :: b c <- genSymSameShapeFresh b + return $ l :*: r + +-- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while +-- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo +-- your own types. +-- +-- This 'simpleFresh' implementation is for the types that can be generated with +-- a reference value of the same type. +-- +-- For sum types, it will generate the result with the same data constructor. +-- For product types, it will generate the result by generating each field with +-- the corresponding reference value. +-- +-- __Note:__ __Can__ be used on recursive types. +derivedSameShapeSimpleFresh :: + forall a m. + ( Generic a, + GenSymSameShape (Rep a), + MonadFresh m + ) => + a -> + m a +derivedSameShapeSimpleFresh a = to <$> genSymSameShapeFresh (from a) + +-- | Symbolically chooses one of the provided values. +-- The procedure creates @n - 1@ fresh symbolic boolean variables every time it +-- is evaluated, and use these variables to conditionally select one of the @n@ +-- provided expressions. +-- +-- The result will be wrapped in a union-like monad, and also a monad +-- maintaining the 'MonadFresh' context. +-- +-- >>> runFresh (chooseFresh [1,2,3]) "a" :: UnionM Integer +-- {If a@0 1 (If a@1 2 3)} +chooseFresh :: + forall bool a m u. + ( Mergeable a, + MonadFresh m + ) => + [a] -> + m (UnionM a) +chooseFresh [x] = return $ mrgSingle x +chooseFresh (r : rs) = do + b <- simpleFresh () + res <- chooseFresh rs + return $ mrgIf b (mrgSingle r) res +chooseFresh [] = error "chooseFresh expects at least one value" + +-- | A wrapper for `chooseFresh` that executes the `MonadFresh` context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +choose :: + forall bool a u. + ( Mergeable a + ) => + [a] -> + FreshIdent -> + UnionM a +choose = runFresh . chooseFresh + +-- | Symbolically chooses one of the provided values. +-- The procedure creates @n - 1@ fresh symbolic boolean variables every time it is evaluated, and use +-- these variables to conditionally select one of the @n@ provided expressions. +-- +-- The result will __/not/__ be wrapped in a union-like monad, but will be +-- wrapped in a monad maintaining the 'Fresh' context. +-- +-- >>> import Data.Proxy +-- >>> runFresh (chooseSimpleFresh [ssym "b", ssym "c", ssym "d"]) "a" :: SymInteger +-- (ite a@0 b (ite a@1 c d)) +chooseSimpleFresh :: + forall a m. + ( SimpleMergeable a, + MonadFresh m + ) => + [a] -> + m a +chooseSimpleFresh [x] = return x +chooseSimpleFresh (r : rs) = do + b :: bool <- simpleFresh () + res <- chooseSimpleFresh rs + return $ mrgIte b r res +chooseSimpleFresh [] = error "chooseSimpleFresh expects at least one value" + +-- | A wrapper for `chooseSimpleFresh` that executes the `MonadFresh` context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +chooseSimple :: + forall a. + ( SimpleMergeable a + ) => + [a] -> + FreshIdent -> + a +chooseSimple = runFresh . chooseSimpleFresh + +-- | Symbolically chooses one of the provided values wrapped in union-like +-- monads. The procedure creates @n - 1@ fresh symbolic boolean variables every +-- time it is evaluated, and use these variables to conditionally select one of +-- the @n@ provided expressions. +-- +-- The result will be wrapped in a union-like monad, and also a monad +-- maintaining the 'Fresh' context. +-- +-- >>> let a = runFresh (chooseFresh [1, 2]) "a" :: UnionM Integer +-- >>> let b = runFresh (chooseFresh [2, 3]) "b" :: UnionM Integer +-- >>> runFresh (chooseUnionFresh [a, b]) "c" :: UnionM Integer +-- {If (&& c@0 a@0) 1 (If (|| c@0 b@0) 2 3)} +chooseUnionFresh :: + forall bool a m u. + ( Mergeable a, + MonadFresh m + ) => + [UnionM a] -> + m (UnionM a) +chooseUnionFresh [x] = return x +chooseUnionFresh (r : rs) = do + b <- simpleFresh () + res <- chooseUnionFresh rs + return $ mrgIf b r res +chooseUnionFresh [] = error "chooseUnionFresh expects at least one value" + +-- | A wrapper for `chooseUnionFresh` that executes the `MonadFresh` context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +chooseUnion :: + forall a u. + ( Mergeable a + ) => + [UnionM a] -> + FreshIdent -> + UnionM a +chooseUnion = runFresh . chooseUnionFresh + +#define CONCRETE_GENSYM_SAME_SHAPE(type) \ +instance GenSym type type where fresh = return . mrgSingle + +#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE(type) \ +instance GenSymSimple type type where simpleFresh = return + +#if 1 +CONCRETE_GENSYM_SAME_SHAPE(Bool) +CONCRETE_GENSYM_SAME_SHAPE(Integer) +CONCRETE_GENSYM_SAME_SHAPE(Char) +CONCRETE_GENSYM_SAME_SHAPE(Int) +CONCRETE_GENSYM_SAME_SHAPE(Int8) +CONCRETE_GENSYM_SAME_SHAPE(Int16) +CONCRETE_GENSYM_SAME_SHAPE(Int32) +CONCRETE_GENSYM_SAME_SHAPE(Int64) +CONCRETE_GENSYM_SAME_SHAPE(Word) +CONCRETE_GENSYM_SAME_SHAPE(Word8) +CONCRETE_GENSYM_SAME_SHAPE(Word16) +CONCRETE_GENSYM_SAME_SHAPE(Word32) +CONCRETE_GENSYM_SAME_SHAPE(Word64) +CONCRETE_GENSYM_SAME_SHAPE(B.ByteString) + +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Bool) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Integer) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Char) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int8) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int16) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int32) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int64) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word8) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word16) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word32) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word64) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(B.ByteString) +#endif + +-- Bool +instance GenSym () Bool where + fresh = derivedNoSpecFresh + +-- Enums + +-- | Specification for enum values with upper bound (exclusive). The result would chosen from [0 .. upperbound]. +-- +-- >>> runFresh (fresh (EnumGenUpperBound @Integer 4)) "c" :: UnionM Integer +-- {If c@0 0 (If c@1 1 (If c@2 2 3))} +newtype EnumGenUpperBound a = EnumGenUpperBound a + +instance (Enum v, Mergeable v) => GenSym (EnumGenUpperBound v) v where + fresh (EnumGenUpperBound u) = chooseFresh (toEnum <$> [0 .. fromEnum u - 1]) + +-- | Specification for numbers with lower bound (inclusive) and upper bound (exclusive) +-- +-- >>> runFresh (fresh (EnumGenBound @Integer 0 4)) "c" :: UnionM Integer +-- {If c@0 0 (If c@1 1 (If c@2 2 3))} +data EnumGenBound a = EnumGenBound a a + +instance (Enum v, Mergeable v) => GenSym (EnumGenBound v) v where + fresh (EnumGenBound l u) = chooseFresh (toEnum <$> [fromEnum l .. fromEnum u - 1]) + +-- Either +instance + ( GenSymSimple a a, + Mergeable a, + GenSymSimple b b, + Mergeable b + ) => + GenSym (Either a b) (Either a b) + +instance + ( GenSymSimple a a, + GenSymSimple b b + ) => + GenSymSimple (Either a b) (Either a b) + where + simpleFresh = derivedSameShapeSimpleFresh + +instance + (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => + GenSym () (Either a b) + where + fresh = derivedNoSpecFresh + +-- Maybe +instance + (GenSymSimple a a, Mergeable a) => + GenSym (Maybe a) (Maybe a) + +instance + (GenSymSimple a a) => + GenSymSimple (Maybe a) (Maybe a) + where + simpleFresh = derivedSameShapeSimpleFresh + +instance (GenSym () a, Mergeable a) => GenSym () (Maybe a) where + fresh = derivedNoSpecFresh + +-- List +instance + (GenSymSimple () a, Mergeable a) => + GenSym Integer [a] + where + fresh v = do + l <- gl v + let xs = reverse $ scanr (:) [] l + chooseFresh xs + where + gl :: (MonadFresh m) => Integer -> m [a] + gl v1 + | v1 <= 0 = return [] + | otherwise = do + l <- simpleFresh () + r <- gl (v1 - 1) + return $ l : r + +-- | Specification for list generation. +-- +-- >>> runFresh (fresh (ListSpec 0 2 ())) "c" :: UnionM [SymBool] +-- {If c@2 [] (If c@3 [c@1] [c@0,c@1])} +-- +-- >>> runFresh (fresh (ListSpec 0 2 (SimpleListSpec 1 ()))) "c" :: UnionM [[SymBool]] +-- {If c@2 [] (If c@3 [[c@1]] [[c@0],[c@1]])} +data ListSpec spec = ListSpec + { -- | The minimum length of the generated lists + genListMinLength :: Int, + -- | The maximum length of the generated lists + genListMaxLength :: Int, + -- | Each element in the lists will be generated with the sub-specification + genListSubSpec :: spec + } + deriving (Show) + +instance + (GenSymSimple spec a, Mergeable a) => + GenSym (ListSpec spec) [a] + where + fresh (ListSpec minLen maxLen subSpec) = + if minLen < 0 || maxLen < 0 || minLen >= maxLen + then error $ "Bad lengths: " ++ show (minLen, maxLen) + else do + l <- gl maxLen + let xs = drop minLen $ reverse $ scanr (:) [] l + chooseFresh xs + where + gl :: (MonadFresh m) => Int -> m [a] + gl currLen + | currLen <= 0 = return [] + | otherwise = do + l <- simpleFresh subSpec + r <- gl (currLen - 1) + return $ l : r + +instance + (GenSymSimple a a, Mergeable a) => + GenSym [a] [a] + +instance + (GenSymSimple a a) => + GenSymSimple [a] [a] + where + simpleFresh = derivedSameShapeSimpleFresh + +-- | Specification for list generation of a specific length. +-- +-- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "c" :: [SymBool] +-- [c@0,c@1] +data SimpleListSpec spec = SimpleListSpec + { -- | The length of the generated list + genSimpleListLength :: Int, + -- | Each element in the list will be generated with the sub-specification + genSimpleListSubSpec :: spec + } + deriving (Show) + +instance + (GenSymSimple spec a, Mergeable a) => + GenSym (SimpleListSpec spec) [a] + where + fresh = fmap mrgSingle . simpleFresh + +instance + (GenSymSimple spec a) => + GenSymSimple (SimpleListSpec spec) [a] + where + simpleFresh (SimpleListSpec len subSpec) = + if len < 0 + then error $ "Bad lengths: " ++ show len + else do + gl len + where + gl :: (MonadFresh m) => Int -> m [a] + gl currLen + | currLen <= 0 = return [] + | otherwise = do + l <- simpleFresh subSpec + r <- gl (currLen - 1) + return $ l : r + +-- () +instance GenSym () () + +instance GenSymSimple () () where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b + ) => + GenSym (aspec, bspec) (a, b) + where + fresh (aspec, bspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + return $ do + ax <- a1 + bx <- b1 + mrgSingle (ax, bx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b + ) => + GenSymSimple (aspec, bspec) (a, b) + where + simpleFresh (aspec, bspec) = do + (,) + <$> simpleFresh aspec + <*> simpleFresh bspec + +instance + (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => + GenSym () (a, b) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b + ) => + GenSymSimple () (a, b) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c + ) => + GenSym (aspec, bspec, cspec) (a, b, c) + where + fresh (aspec, bspec, cspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + mrgSingle (ax, bx, cx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c + ) => + GenSymSimple (aspec, bspec, cspec) (a, b, c) + where + simpleFresh (aspec, bspec, cspec) = do + (,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c + ) => + GenSym () (a, b, c) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c + ) => + GenSymSimple () (a, b, c) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d + ) => + GenSym (aspec, bspec, cspec, dspec) (a, b, c, d) + where + fresh (aspec, bspec, cspec, dspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + mrgSingle (ax, bx, cx, dx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d + ) => + GenSymSimple (aspec, bspec, cspec, dspec) (a, b, c, d) + where + simpleFresh (aspec, bspec, cspec, dspec) = do + (,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d + ) => + GenSym () (a, b, c, d) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d + ) => + GenSymSimple () (a, b, c, d) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e + ) => + GenSym (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) + where + fresh (aspec, bspec, cspec, dspec, espec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + mrgSingle (ax, bx, cx, dx, ex) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) + where + simpleFresh (aspec, bspec, cspec, dspec, espec) = do + (,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e + ) => + GenSym () (a, b, c, d, e) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e + ) => + GenSymSimple () (a, b, c, d, e) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e, + GenSym fspec f, + Mergeable f + ) => + GenSym (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) + where + fresh (aspec, bspec, cspec, dspec, espec, fspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + f1 <- fresh fspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + fx <- f1 + mrgSingle (ax, bx, cx, dx, ex, fx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e, + GenSymSimple fspec f + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) + where + simpleFresh (aspec, bspec, cspec, dspec, espec, fspec) = do + (,,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + <*> simpleFresh fspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e, + GenSym () f, + Mergeable f + ) => + GenSym () (a, b, c, d, e, f) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e, + GenSymSimple () f + ) => + GenSymSimple () (a, b, c, d, e, f) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e, + GenSym fspec f, + Mergeable f, + GenSym gspec g, + Mergeable g + ) => + GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) + where + fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + f1 <- fresh fspec + g1 <- fresh gspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + fx <- f1 + gx <- g1 + mrgSingle (ax, bx, cx, dx, ex, fx, gx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e, + GenSymSimple fspec f, + GenSymSimple gspec g + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) + where + simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do + (,,,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + <*> simpleFresh fspec + <*> simpleFresh gspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e, + GenSym () f, + Mergeable f, + GenSym () g, + Mergeable g + ) => + GenSym () (a, b, c, d, e, f, g) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e, + GenSymSimple () f, + GenSymSimple () g + ) => + GenSymSimple () (a, b, c, d, e, f, g) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e, + GenSym fspec f, + Mergeable f, + GenSym gspec g, + Mergeable g, + GenSym hspec h, + Mergeable h + ) => + GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) + where + fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + f1 <- fresh fspec + g1 <- fresh gspec + h1 <- fresh hspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + fx <- f1 + gx <- g1 + hx <- h1 + mrgSingle (ax, bx, cx, dx, ex, fx, gx, hx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e, + GenSymSimple fspec f, + GenSymSimple gspec g, + GenSymSimple hspec h + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) + where + simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do + (,,,,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + <*> simpleFresh fspec + <*> simpleFresh gspec + <*> simpleFresh hspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e, + GenSym () f, + Mergeable f, + GenSym () g, + Mergeable g, + GenSym () h, + Mergeable h + ) => + GenSym () (a, b, c, d, e, f, g, h) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e, + GenSymSimple () f, + GenSymSimple () g, + GenSymSimple () h + ) => + GenSymSimple () (a, b, c, d, e, f, g, h) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- MaybeT +instance + {-# OVERLAPPABLE #-} + ( GenSym spec (m (Maybe a)), + Mergeable1 m, + Mergeable a + ) => + GenSym spec (MaybeT m a) + where + fresh v = do + x <- fresh v + return $ merge . fmap MaybeT $ x + +instance + {-# OVERLAPPABLE #-} + ( GenSymSimple spec (m (Maybe a)) + ) => + GenSymSimple spec (MaybeT m a) + where + simpleFresh v = MaybeT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Maybe a)) (m (Maybe a)) + ) => + GenSymSimple (MaybeT m a) (MaybeT m a) + where + simpleFresh (MaybeT v) = MaybeT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Maybe a)) (m (Maybe a)), + Mergeable1 m, + Mergeable a + ) => + GenSym (MaybeT m a) (MaybeT m a) + +-- ExceptT +instance + {-# OVERLAPPABLE #-} + ( GenSym spec (m (Either a b)), + Mergeable1 m, + Mergeable a, + Mergeable b + ) => + GenSym spec (ExceptT a m b) + where + fresh v = do + x <- fresh v + return $ merge . fmap ExceptT $ x + +instance + {-# OVERLAPPABLE #-} + ( GenSymSimple spec (m (Either a b)) + ) => + GenSymSimple spec (ExceptT a m b) + where + simpleFresh v = ExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Either e a)) (m (Either e a)) + ) => + GenSymSimple (ExceptT e m a) (ExceptT e m a) + where + simpleFresh (ExceptT v) = ExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Either e a)) (m (Either e a)), + Mergeable1 m, + Mergeable e, + Mergeable a + ) => + GenSym (ExceptT e m a) (ExceptT e m a) + +instance (SupportedPrim a) => GenSym (Sym a) (Sym a) + +instance (SupportedPrim a) => GenSymSimple (Sym a) (Sym a) where + simpleFresh _ = simpleFresh () + +instance (SupportedPrim a) => GenSym () (Sym a) where + fresh _ = mrgSingle <$> simpleFresh () + +instance (SupportedPrim a) => GenSymSimple () (Sym a) where + simpleFresh _ = do + ident <- getFreshIdent + FreshIndex i <- nextFreshIndex + case ident of + FreshIdent s -> return $ isym s i + FreshIdentWithInfo s info -> return $ iinfosym s i info diff --git a/src/Grisette/Core/Data/Class/Integer.hs b/src/Grisette/Core/Data/Class/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Integer.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.Data.Class.Integer +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Integer + ( -- * Symbolic integer operations + ArithException (..), + SignedDivMod (..), + UnsignedDivMod (..), + SignedQuotRem (..), + SymIntegerOp, + ) +where + +import Control.Exception +import Control.Monad.Except +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Error +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.Solvable + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | Safe signed 'div' and 'mod' with monadic error handling in multi-path +-- execution. These procedures show throw 'DivideByZero' exception when the +-- divisor is zero. The result should be able to handle errors with +-- `MonadError`, and the error type should be compatible with 'ArithException' +-- (see 'TransformError' for more details). +class SignedDivMod a where + -- | Safe signed 'div' with monadic error handling in multi-path execution. + -- + -- >>> divs (ssym "a") (ssym "b") :: ExceptT AssertionError UnionM SymInteger + -- ExceptT {If (= b 0) (Left AssertionError) (Right (div a b))} + divs :: (MonadError e uf, MonadUnion uf, TransformError ArithException e) => a -> a -> uf a + + -- | Safe signed 'mod' with monadic error handling in multi-path execution. + -- + -- >>> mods (ssym "a") (ssym "b") :: ExceptT AssertionError UnionM SymInteger + -- ExceptT {If (= b 0) (Left AssertionError) (Right (mod a b))} + mods :: (MonadError e uf, MonadUnion uf, TransformError ArithException e) => a -> a -> uf a + +-- | Safe unsigned 'div' and 'mod' with monadic error handling in multi-path +-- execution. These procedures show throw 'DivideByZero' exception when the +-- divisor is zero. The result should be able to handle errors with +-- `MonadError`, and the error type should be compatible with 'ArithException' +-- (see 'TransformError' for more details). +class UnsignedDivMod a where + udivs :: (MonadError e uf, MonadUnion uf, TransformError ArithException e) => a -> a -> uf a + umods :: (MonadError e uf, MonadUnion uf, TransformError ArithException e) => a -> a -> uf a + +-- | Safe signed 'quot' and 'rem' with monadic error handling in multi-path +-- execution. These procedures show throw 'DivideByZero' exception when the +-- divisor is zero. The result should be able to handle errors with +-- `MonadError`, and the error type should be compatible with 'ArithException' +-- (see 'TransformError' for more details). +class SignedQuotRem a where + quots :: (MonadError e uf, MonadUnion uf, TransformError ArithException e) => a -> a -> uf a + rems :: (MonadError e uf, MonadUnion uf, TransformError ArithException e) => a -> a -> uf a + +-- | Aggregation for the operations on symbolic integer types +class (Num a, SEq a, SOrd a, Solvable Integer a) => SymIntegerOp a diff --git a/src/Grisette/Core/Data/Class/Mergeable.hs b/src/Grisette/Core/Data/Class/Mergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Mergeable.hs @@ -0,0 +1,939 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.Mergeable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Mergeable + ( -- * Merging strategy + MergingStrategy (..), + + -- * Mergeable + Mergeable (..), + Mergeable1 (..), + rootStrategy1, + Mergeable2 (..), + rootStrategy2, + Mergeable3 (..), + rootStrategy3, + Mergeable' (..), + derivedRootStrategy, + + -- * Combinators for manually building merging strategies + wrapStrategy, + product2Strategy, + DynamicSortedIdx (..), + StrategyList (..), + buildStrategyList, + resolveStrategy, + resolveStrategy', + ) +where + +import Control.Monad.Cont +import Control.Monad.Except +import Control.Monad.Identity +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes +import Data.Functor.Sum +import Data.Int +import Data.Kind +import qualified Data.Monoid as Monoid +import Data.Typeable +import Data.Word +import Generics.Deriving +import Grisette.Core.Data.Class.Bool +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim +import Unsafe.Coerce + +-- | Helper type for combining arbitrary number of indices into one. +-- Useful when trying to write efficient merge strategy for lists/vectors. +data DynamicSortedIdx where + DynamicSortedIdx :: forall idx. (Show idx, Ord idx, Typeable idx) => idx -> DynamicSortedIdx + +instance Eq DynamicSortedIdx where + (DynamicSortedIdx (a :: a)) == (DynamicSortedIdx (b :: b)) = case eqT @a @b of + Just Refl -> a == b + _ -> False + {-# INLINE (==) #-} + +instance Ord DynamicSortedIdx where + compare (DynamicSortedIdx (a :: a)) (DynamicSortedIdx (b :: b)) = case eqT @a @b of + Just Refl -> compare a b + _ -> error "This Ord is incomplete" + {-# INLINE compare #-} + +instance Show DynamicSortedIdx where + show (DynamicSortedIdx a) = show a + +-- | Resolves the indices and the terminal merge strategy for a value of some 'Mergeable' type. +resolveStrategy :: forall x. MergingStrategy x -> x -> ([DynamicSortedIdx], MergingStrategy x) +resolveStrategy s x = resolveStrategy' x s +{-# INLINE resolveStrategy #-} + +-- | Resolves the indices and the terminal merge strategy for a value given a merge strategy for its type. +resolveStrategy' :: forall x. x -> MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) +resolveStrategy' x = go + where + go :: MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) + go (SortedStrategy idxFun subStrategy) = case go ss of + (idxs, r) -> (DynamicSortedIdx idx : idxs, r) + where + idx = idxFun x + ss = subStrategy idx + go s = ([], s) +{-# INLINE resolveStrategy' #-} + +-- | Merging strategies. +-- +-- __You probably do not need to know the details of this type if you are only going__ +-- __to use algebraic data types. You can get merging strategies for them with type__ +-- __derivation.__ +-- +-- In Grisette, a merged union (if-then-else tree) follows the __/hierarchical/__ +-- __/sorted representation invariant/__ with regards to some merging strategy. +-- +-- A merging strategy encodes how to merge a __/subset/__ of the values of a +-- given type. We have three types of merging strategies: +-- +-- * Simple strategy +-- * Sorted strategy +-- * No strategy +-- +-- The 'SimpleStrategy' merges values with a simple merge function. +-- For example, +-- +-- * the symbolic boolean values can be directly merged with 'ites'. +-- +-- * the set @{1}@, which is a subset of the values of the type @Integer@, +-- can be simply merged as the set contains only a single value. +-- +-- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged +-- by merging the wrapped symbolic boolean with 'ites'. +-- +-- The 'SortedStrategy' merges values by first grouping the values with an +-- indexing function, and the values with the same index will be organized as +-- a sub-tree in the if-then-else structure of 'Grisette.Core.Data.UnionBase.UnionBase'. +-- Each group (sub-tree) will be further merged with a sub-strategy for the +-- index. +-- The index type should be a totally ordered type (with the 'Ord' +-- type class). Grisette will use the indexing function to partition the values +-- into sub-trees, and organize them in a sorted way. The sub-trees will further +-- be merged with the sub-strategies. For example, +-- +-- * all the integers can be merged with 'SortedStrategy' by indexing with +-- the identity function and use the 'SimpleStrategy' shown before as the +-- sub-strategies. +-- +-- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by +-- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can then +-- then be merged with different simple strategies as sub-strategies. +-- +-- The 'NoStrategy' does not perform any merging. +-- For example, we cannot merge values with function types that returns concrete +-- lists. +-- +-- For ADTs, we can automatically derive the 'Mergeable' type class, which +-- provides a merging strategy. +-- +-- If the derived version does not work for you, you should determine +-- if your type can be directly merged with a merging function. If so, you can +-- implement the merging strategy as a 'SimpleStrategy'. +-- If the type cannot be directly merged with a merging function, but could be +-- partitioned into subsets of values that can be simply merged with a function, +-- you should implement the merging strategy as a 'SortedStrategy'. +-- For easier building of the merging strategies, check out the combinators +-- like `wrapStrategy`. +-- +-- For more details, please see the documents of the constructors, or refer to +-- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). +data MergingStrategy a where + -- | Simple mergeable strategy. + -- + -- For symbolic booleans, we can implement its merge strategy as follows: + -- + -- > SimpleStrategy ites :: MergingStrategy SymBool + SimpleStrategy :: + -- | Merge function. + (SymBool -> a -> a -> a) -> + MergingStrategy a + -- | Sorted mergeable strategy. + -- + -- For Integers, we can implement its merge strategy as follows: + -- + -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) + -- + -- For @Maybe SymBool@, we can implement its merge strategy as follows: + -- + -- > SortedStrategy + -- > (\case; Nothing -> False; Just _ -> True) + -- > (\idx -> + -- > if idx + -- > then SimpleStrategy $ \_ t _ -> t + -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ ites cond l r) + SortedStrategy :: + (Ord idx, Typeable idx, Show idx) => + -- | Indexing function + (a -> idx) -> + -- | Sub-strategy function + (idx -> MergingStrategy a) -> + MergingStrategy a + -- | For preventing the merging intentionally. This could be + -- useful for keeping some value concrete and may help generate more efficient + -- formulas. + -- + -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for + -- details. + NoStrategy :: MergingStrategy a + +-- | Useful utility function for building merge strategies manually. +-- +-- For example, to build the merge strategy for the just branch of @Maybe a@, +-- one could write +-- +-- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) +wrapStrategy :: + -- | The merge strategy to be wrapped + MergingStrategy a -> + -- | The wrap function + (a -> b) -> + -- | The unwrap function, which does not have to be defined for every value + (b -> a) -> + MergingStrategy b +wrapStrategy (SimpleStrategy m) wrap unwrap = + SimpleStrategy + ( \cond ifTrue ifFalse -> + wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) + ) +wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = + SortedStrategy + (idxFun . unwrap) + (\idx -> wrapStrategy (substrategy idx) wrap unwrap) +wrapStrategy NoStrategy _ _ = NoStrategy +{-# INLINE wrapStrategy #-} + +-- | Each type is associated with a root merge strategy given by 'rootStrategy'. +-- The root merge strategy should be able to merge every value of the type. +-- Grisette will use the root merge strategy to merge the values of the type in +-- a union. +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving Mergeable via (Default X) +class Mergeable a where + -- | The root merging strategy for the type. + rootStrategy :: MergingStrategy a + +instance (Generic a, Mergeable' (Rep a)) => Mergeable (Default a) where + rootStrategy = unsafeCoerce (derivedRootStrategy :: MergingStrategy a) + {-# NOINLINE rootStrategy #-} + +-- | Generic derivation for the 'Mergeable' class. +-- +-- Usually you can derive the merging strategy with the @DerivingVia@ and +-- @DerivingStrategies@ extension. +-- +-- > data X = ... deriving (Generic) deriving Mergeable via (Default X) +derivedRootStrategy :: (Generic a, Mergeable' (Rep a)) => MergingStrategy a +derivedRootStrategy = wrapStrategy rootStrategy' to from +{-# INLINE derivedRootStrategy #-} + +-- | Lifting of the 'Mergeable' class to unary type constructors. +class Mergeable1 (u :: Type -> Type) where + -- | Lift merge strategy through the type constructor. + liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) + +-- | Lift the root merge strategy through the unary type constructor. +rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) +rootStrategy1 = liftRootStrategy rootStrategy +{-# INLINE rootStrategy1 #-} + +-- | Lifting of the 'Mergeable' class to binary type constructors. +class Mergeable2 (u :: Type -> Type -> Type) where + -- | Lift merge strategy through the type constructor. + liftRootStrategy2 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy (u a b) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy2 :: (Mergeable a, Mergeable b, Mergeable2 u) => MergingStrategy (u a b) +rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy +{-# INLINE rootStrategy2 #-} + +-- | Lifting of the 'Mergeable' class to ternary type constructors. +class Mergeable3 (u :: Type -> Type -> Type -> Type) where + -- | Lift merge strategy through the type constructor. + liftRootStrategy3 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy c -> MergingStrategy (u a b c) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy3 :: (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => MergingStrategy (u a b c) +rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy +{-# INLINE rootStrategy3 #-} + +instance (Generic1 u, Mergeable1' (Rep1 u)) => Mergeable1 (Default1 u) where + liftRootStrategy = unsafeCoerce (derivedLiftMergingStrategy :: MergingStrategy a -> MergingStrategy (u a)) + {-# NOINLINE liftRootStrategy #-} + +class Mergeable1' (u :: Type -> Type) where + liftRootStrategy' :: MergingStrategy a -> MergingStrategy (u a) + +instance Mergeable1' U1 where + liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE liftRootStrategy' #-} + +instance Mergeable1' V1 where + liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE liftRootStrategy' #-} + +instance Mergeable1' Par1 where + liftRootStrategy' m = wrapStrategy m Par1 unPar1 + {-# INLINE liftRootStrategy' #-} + +instance Mergeable1 f => Mergeable1' (Rec1 f) where + liftRootStrategy' m = wrapStrategy (liftRootStrategy m) Rec1 unRec1 + {-# INLINE liftRootStrategy' #-} + +instance Mergeable c => Mergeable1' (K1 i c) where + liftRootStrategy' _ = wrapStrategy rootStrategy K1 unK1 + {-# INLINE liftRootStrategy' #-} + +instance Mergeable1' a => Mergeable1' (M1 i c a) where + liftRootStrategy' m = wrapStrategy (liftRootStrategy' m) M1 unM1 + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :+: b) where + liftRootStrategy' m = + SortedStrategy + ( \case + L1 _ -> False + R1 _ -> True + ) + ( \idx -> + if not idx + then wrapStrategy (liftRootStrategy' m) L1 (\case (L1 v) -> v; _ -> error "impossible") + else wrapStrategy (liftRootStrategy' m) R1 (\case (R1 v) -> v; _ -> error "impossible") + ) + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :*: b) where + liftRootStrategy' m = product2Strategy (:*:) (\(a :*: b) -> (a, b)) (liftRootStrategy' m) (liftRootStrategy' m) + {-# INLINE liftRootStrategy' #-} + +-- | Generic derivation for the 'Mergeable' class. +derivedLiftMergingStrategy :: (Generic1 u, Mergeable1' (Rep1 u)) => MergingStrategy a -> MergingStrategy (u a) +derivedLiftMergingStrategy m = wrapStrategy (liftRootStrategy' m) to1 from1 +{-# INLINE derivedLiftMergingStrategy #-} + +-- | Auxiliary class for the generic derivation for the 'Mergeable' class. +class Mergeable' f where + rootStrategy' :: MergingStrategy (f a) + +instance Mergeable' U1 where + rootStrategy' = SimpleStrategy (\_ t _ -> t) + {-# INLINE rootStrategy' #-} + +instance Mergeable' V1 where + rootStrategy' = SimpleStrategy (\_ t _ -> t) + {-# INLINE rootStrategy' #-} + +instance (Mergeable c) => Mergeable' (K1 i c) where + rootStrategy' = wrapStrategy rootStrategy K1 unK1 + {-# INLINE rootStrategy' #-} + +instance (Mergeable' a) => Mergeable' (M1 i c a) where + rootStrategy' = wrapStrategy rootStrategy' M1 unM1 + {-# INLINE rootStrategy' #-} + +instance (Mergeable' a, Mergeable' b) => Mergeable' (a :+: b) where + rootStrategy' = + SortedStrategy + ( \case + L1 _ -> False + R1 _ -> True + ) + ( \idx -> + if not idx + then wrapStrategy rootStrategy' L1 (\case (L1 v) -> v; _ -> undefined) + else wrapStrategy rootStrategy' R1 (\case (R1 v) -> v; _ -> undefined) + ) + {-# INLINE rootStrategy' #-} + +-- | Useful utility function for building merge strategies for product types +-- manually. +-- +-- For example, to build the merge strategy for the following product type, +-- one could write +-- +-- > data X = X { x1 :: Int, x2 :: Bool } +-- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy +-- > :: MergingStrategy X +product2Strategy :: + -- | The wrap function + (a -> b -> r) -> + -- | The unwrap function, which does not have to be defined for every value + (r -> (a, b)) -> + -- | The first merge strategy to be wrapped + MergingStrategy a -> + -- | The second merge strategy to be wrapped + MergingStrategy b -> + MergingStrategy r +product2Strategy wrap unwrap strategy1 strategy2 = + case (strategy1, strategy2) of + (NoStrategy, _) -> NoStrategy + (_, NoStrategy) -> NoStrategy + (SimpleStrategy m1, SimpleStrategy m2) -> + SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of + ((hdt, tlt), (hdf, tlf)) -> + wrap (m1 cond hdt hdf) (m2 cond tlt tlf) + (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> + SortedStrategy (idxf . snd . unwrap) (product2Strategy wrap unwrap s1 . subf) + (SortedStrategy idxf subf, s2) -> + SortedStrategy (idxf . fst . unwrap) (\idx -> product2Strategy wrap unwrap (subf idx) s2) +{-# INLINE product2Strategy #-} + +instance (Mergeable' a, Mergeable' b) => Mergeable' (a :*: b) where + rootStrategy' = product2Strategy (:*:) (\(a :*: b) -> (a, b)) rootStrategy' rootStrategy' + {-# INLINE rootStrategy' #-} + +-- instances + +#define CONCRETE_ORD_MERGEABLE(type) \ +instance Mergeable type where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub; \ + {-# INLINE rootStrategy #-} + +#if 1 +CONCRETE_ORD_MERGEABLE(Bool) +CONCRETE_ORD_MERGEABLE(Integer) +CONCRETE_ORD_MERGEABLE(Char) +CONCRETE_ORD_MERGEABLE(Int) +CONCRETE_ORD_MERGEABLE(Int8) +CONCRETE_ORD_MERGEABLE(Int16) +CONCRETE_ORD_MERGEABLE(Int32) +CONCRETE_ORD_MERGEABLE(Int64) +CONCRETE_ORD_MERGEABLE(Word) +CONCRETE_ORD_MERGEABLE(Word8) +CONCRETE_ORD_MERGEABLE(Word16) +CONCRETE_ORD_MERGEABLE(Word32) +CONCRETE_ORD_MERGEABLE(Word64) +CONCRETE_ORD_MERGEABLE(B.ByteString) +#endif + +-- () +deriving via (Default ()) instance Mergeable () + +-- Either +deriving via (Default (Either e a)) instance (Mergeable e, Mergeable a) => Mergeable (Either e a) + +deriving via (Default1 (Either e)) instance (Mergeable e) => Mergeable1 (Either e) + +instance Mergeable2 Either where + liftRootStrategy2 m1 m2 = + SortedStrategy + ( \case + Left _ -> False + Right _ -> True + ) + ( \case + False -> wrapStrategy m1 Left (\case (Left v) -> v; _ -> undefined) + True -> wrapStrategy m2 Right (\case (Right v) -> v; _ -> undefined) + ) + {-# INLINE liftRootStrategy2 #-} + +-- Maybe +deriving via (Default (Maybe a)) instance (Mergeable a) => Mergeable (Maybe a) + +deriving via (Default1 Maybe) instance Mergeable1 Maybe + +-- | Helper type for building efficient merge strategy for list-like containers. +data StrategyList container where + StrategyList :: + forall bool a container. + container [DynamicSortedIdx] -> + container (MergingStrategy a) -> + StrategyList container + +-- | Helper function for building efficient merge strategy for list-like containers. +buildStrategyList :: + forall bool a container. + (Functor container) => + MergingStrategy a -> + container a -> + StrategyList container +buildStrategyList s l = StrategyList idxs strategies + where + r = resolveStrategy s <$> l + idxs = fst <$> r + strategies = snd <$> r +{-# INLINE buildStrategyList #-} + +instance Eq1 container => Eq (StrategyList container) where + (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 + {-# INLINE (==) #-} + +instance Ord1 container => Ord (StrategyList container) where + compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 + {-# INLINE compare #-} + +instance Show1 container => Show (StrategyList container) where + showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 + +-- List +instance (Mergeable a) => Mergeable [a] where + rootStrategy = case rootStrategy :: MergingStrategy a of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList rootStrategy) $ \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r + else NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 [] where + liftRootStrategy (ms :: MergingStrategy a) = case ms of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r + else NoStrategy + {-# INLINE liftRootStrategy #-} + +-- (,) +deriving via (Default (a, b)) instance (Mergeable a, Mergeable b) => Mergeable (a, b) + +deriving via (Default1 ((,) a)) instance (Mergeable a) => Mergeable1 ((,) a) + +instance Mergeable2 (,) where + liftRootStrategy2 = product2Strategy (,) id + {-# INLINE liftRootStrategy2 #-} + +-- (,,) +deriving via + (Default (a, b, c)) + instance + (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) + +deriving via + (Default1 ((,,) a b)) + instance + (Mergeable a, Mergeable b) => Mergeable1 ((,,) a b) + +instance (Mergeable a) => Mergeable2 ((,,) a) where + liftRootStrategy2 = liftRootStrategy3 rootStrategy + {-# INLINE liftRootStrategy2 #-} + +instance Mergeable3 (,,) where + liftRootStrategy3 m1 m2 m3 = + product2Strategy + (\a (b, c) -> (a, b, c)) + (\(a, b, c) -> (a, (b, c))) + m1 + (liftRootStrategy2 m2 m3) + {-# INLINE liftRootStrategy3 #-} + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + Mergeable (a, b, c, d) + +deriving via + (Default1 ((,,,) a b c)) + instance + (Mergeable a, Mergeable b, Mergeable c) => + Mergeable1 ((,,,) a b c) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => + Mergeable (a, b, c, d, e) + +deriving via + (Default1 ((,,,,) a b c d)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + Mergeable1 ((,,,,) a b c d) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f + ) => + Mergeable (a, b, c, d, e, f) + +deriving via + (Default1 ((,,,,,) a b c d e)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => + Mergeable1 ((,,,,,) a b c d e) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f, + Mergeable g + ) => + Mergeable (a, b, c, d, e, f, g) + +deriving via + (Default1 ((,,,,,,) a b c d e f)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f + ) => + Mergeable1 ((,,,,,,) a b c d e f) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f, + Mergeable g, + Mergeable h + ) => + Mergeable (a, b, c, d, e, f, g, h) + +deriving via + (Default1 ((,,,,,,,) a b c d e f g)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f, + Mergeable g + ) => + Mergeable1 ((,,,,,,,) a b c d e f g) + +-- function +instance (Mergeable b) => Mergeable (a -> b) where + rootStrategy = case rootStrategy @b of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 ((->) a) where + liftRootStrategy ms = case ms of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE liftRootStrategy #-} + +-- MaybeT +instance (Mergeable1 m, Mergeable a) => Mergeable (MaybeT m a) where + rootStrategy = wrapStrategy rootStrategy1 MaybeT runMaybeT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (MaybeT m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) MaybeT runMaybeT + {-# INLINE liftRootStrategy #-} + +-- ExceptT +instance + (Mergeable1 m, Mergeable e, Mergeable a) => + Mergeable (ExceptT e m a) + where + rootStrategy = wrapStrategy rootStrategy1 ExceptT runExceptT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable e) => Mergeable1 (ExceptT e m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) ExceptT runExceptT + {-# INLINE liftRootStrategy #-} + +-- state +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (StateLazy.StateT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) StateLazy.StateT StateLazy.runStateT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateLazy.StateT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) + StateLazy.StateT + StateLazy.runStateT + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (StateStrict.StateT s m a) + where + rootStrategy = + wrapStrategy (liftRootStrategy rootStrategy1) StateStrict.StateT StateStrict.runStateT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateStrict.StateT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) + StateStrict.StateT + StateStrict.runStateT + {-# INLINE liftRootStrategy #-} + +-- writer +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (WriterLazy.WriterT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterLazy.WriterT WriterLazy.runWriterT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterLazy.WriterT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy2 m rootStrategy)) + WriterLazy.WriterT + WriterLazy.runWriterT + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (WriterStrict.WriterT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterStrict.WriterT WriterStrict.runWriterT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterStrict.WriterT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy2 m rootStrategy)) + WriterStrict.WriterT + WriterStrict.runWriterT + {-# INLINE liftRootStrategy #-} + +-- reader +instance + (Mergeable a, Mergeable1 m) => + Mergeable (ReaderT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) ReaderT runReaderT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy m)) + ReaderT + runReaderT + {-# INLINE liftRootStrategy #-} + +-- Sum +instance + (Mergeable1 l, Mergeable1 r, Mergeable x) => + Mergeable (Sum l r x) + where + rootStrategy = + SortedStrategy + ( \case + InL _ -> False + InR _ -> True + ) + ( \case + False -> wrapStrategy rootStrategy1 InL (\case (InL v) -> v; _ -> error "impossible") + True -> wrapStrategy rootStrategy1 InR (\case (InR v) -> v; _ -> error "impossible") + ) + {-# INLINE rootStrategy #-} + +instance (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) where + liftRootStrategy m = + SortedStrategy + ( \case + InL _ -> False + InR _ -> True + ) + ( \case + False -> wrapStrategy (liftRootStrategy m) InL (\case (InL v) -> v; _ -> error "impossible") + True -> wrapStrategy (liftRootStrategy m) InR (\case (InR v) -> v; _ -> error "impossible") + ) + {-# INLINE liftRootStrategy #-} + +-- Ordering +deriving via + (Default Ordering) + instance + Mergeable Ordering + +-- Generic +deriving via + (Default (U1 x)) + instance + Mergeable (U1 x) + +deriving via + (Default (V1 x)) + instance + Mergeable (V1 x) + +deriving via + (Default (K1 i c x)) + instance + (Mergeable c) => Mergeable (K1 i c x) + +deriving via + (Default (M1 i c a x)) + instance + (Mergeable (a x)) => Mergeable (M1 i c a x) + +deriving via + (Default ((a :+: b) x)) + instance + (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :+: b) x) + +deriving via + (Default ((a :*: b) x)) + instance + (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :*: b) x) + +-- Identity +instance (Mergeable a) => Mergeable (Identity a) where + rootStrategy = wrapStrategy rootStrategy Identity runIdentity + {-# INLINE rootStrategy #-} + +instance Mergeable1 Identity where + liftRootStrategy m = wrapStrategy m Identity runIdentity + {-# INLINE liftRootStrategy #-} + +-- IdentityT +instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where + rootStrategy = wrapStrategy rootStrategy1 IdentityT runIdentityT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (IdentityT m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT + {-# INLINE liftRootStrategy #-} + +-- ContT +instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where + rootStrategy = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where + liftRootStrategy _ = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE liftRootStrategy #-} + +-- RWS +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSLazy.RWST r w s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSLazy.RWST (\(RWSLazy.RWST m) -> m) + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSLazy.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) + RWSLazy.RWST + (\(RWSLazy.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSStrict.RWST r w s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSStrict.RWST (\(RWSStrict.RWST m) -> m) + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSStrict.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) + RWSStrict.RWST + (\(RWSStrict.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +-- Data.Monoid module +deriving via + (Default (Monoid.Sum a)) + instance + (Mergeable a) => Mergeable (Monoid.Sum a) + +deriving via (Default1 Monoid.Sum) instance Mergeable1 Monoid.Sum + +instance (SupportedPrim a) => Mergeable (Sym a) where + rootStrategy = SimpleStrategy ites diff --git a/src/Grisette/Core/Data/Class/Mergeable.hs-boot b/src/Grisette/Core/Data/Class/Mergeable.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Mergeable.hs-boot @@ -0,0 +1,23 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} + +module Grisette.Core.Data.Class.Mergeable where + +import Data.Typeable +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +data MergingStrategy a where + SimpleStrategy :: (SymBool -> a -> a -> a) -> MergingStrategy a + SortedStrategy :: + (Ord idx, Typeable idx, Show idx) => + (a -> idx) -> + (idx -> MergingStrategy a) -> + MergingStrategy a + NoStrategy :: MergingStrategy a + +class Mergeable' f where + rootStrategy' :: MergingStrategy (f a) + +class Mergeable a where + rootStrategy :: MergingStrategy a diff --git a/src/Grisette/Core/Data/Class/ModelOps.hs b/src/Grisette/Core/Data/Class/ModelOps.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/ModelOps.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Core.Data.Class.ModelOps +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.ModelOps + ( -- * Model and symbolic set operations + SymbolSetOps (..), + SymbolSetRep (..), + ModelOps (..), + ModelRep (..), + ) +where + +import Data.Hashable +import Data.Kind +import Data.Typeable + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | The operations on symbolic constant sets +-- +-- Note that symbolic constants with different types are considered different. +-- +-- >>> let aBool = "a" :: TypedSymbol Bool +-- >>> let bBool = "b" :: TypedSymbol Bool +-- >>> let cBool = "c" :: TypedSymbol Bool +-- >>> let aInteger = "a" :: TypedSymbol Integer +-- >>> emptySet :: SymbolSet +-- SymbolSet {} +-- >>> containsSymbol aBool (buildSymbolSet aBool :: SymbolSet) +-- True +-- >>> containsSymbol bBool (buildSymbolSet aBool :: SymbolSet) +-- False +-- >>> insertSymbol aBool (buildSymbolSet aBool :: SymbolSet) +-- SymbolSet {a :: Bool} +-- >>> insertSymbol aInteger (buildSymbolSet aBool :: SymbolSet) +-- SymbolSet {a :: Bool, a :: Integer} +-- >>> let abSet = buildSymbolSet (aBool, bBool) :: SymbolSet +-- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet +-- >>> intersectionSet abSet acSet +-- SymbolSet {a :: Bool} +-- >>> unionSet abSet acSet +-- SymbolSet {a :: Bool, b :: Bool, c :: Bool} +-- >>> differenceSet abSet acSet +-- SymbolSet {b :: Bool} +class + Monoid symbolSet => + SymbolSetOps symbolSet (typedSymbol :: Type -> Type) + | symbolSet -> typedSymbol + where + -- | Construct an empty set + emptySet :: symbolSet + + -- | Check if the set is empty + isEmptySet :: symbolSet -> Bool + + -- | Check if the set contains the given symbol + containsSymbol :: forall a. typedSymbol a -> symbolSet -> Bool + + -- | Insert a symbol into the set + insertSymbol :: forall a. typedSymbol a -> symbolSet -> symbolSet + + -- | Set intersection + intersectionSet :: symbolSet -> symbolSet -> symbolSet + + -- | Set union + unionSet :: symbolSet -> symbolSet -> symbolSet + + -- | Set difference + differenceSet :: symbolSet -> symbolSet -> symbolSet + +-- | A type class for building a symbolic constant set manually from a symbolic +-- constant set representation +-- +-- >>> buildSymbolSet ("a" :: TypedSymbol Bool, "b" :: TypedSymbol Bool) :: SymbolSet +-- SymbolSet {a :: Bool, b :: Bool} +class + SymbolSetOps symbolSet typedSymbol => + SymbolSetRep rep symbolSet (typedSymbol :: * -> *) + where + -- | Build a symbolic constant set + buildSymbolSet :: rep -> symbolSet + +-- | The operations on Models. +-- +-- Note that symbolic constants with different types are considered different. +-- +-- >>> let aBool = "a" :: TypedSymbol Bool +-- >>> let bBool = "b" :: TypedSymbol Bool +-- >>> let cBool = "c" :: TypedSymbol Bool +-- >>> let aInteger = "a" :: TypedSymbol Integer +-- >>> emptyModel :: Model +-- Model {} +-- >>> valueOf aBool (buildModel (aBool ::= True) :: Model) +-- Just True +-- >>> valueOf bBool (buildModel (aBool ::= True) :: Model) +-- Nothing +-- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model) +-- Model {a -> True :: Bool, b -> False :: Bool} +-- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model +-- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet +-- >>> exceptFor acSet abModel +-- Model {b -> False :: Bool} +-- >>> restrictTo acSet abModel +-- Model {a -> True :: Bool} +-- >>> extendTo acSet abModel +-- Model {a -> True :: Bool, b -> False :: Bool, c -> False :: Bool} +-- >>> exact acSet abModel +-- Model {a -> True :: Bool, c -> False :: Bool} +class + SymbolSetOps symbolSet typedSymbol => + ModelOps model symbolSet typedSymbol + | model -> symbolSet typedSymbol + where + -- | Construct an empty model + emptyModel :: model + + -- | Check if the model is empty + isEmptyModel :: model -> Bool + + -- | Extract the assigned value for a given symbolic constant + valueOf :: typedSymbol t -> model -> Maybe t + + -- | Insert an assignment into the model + insertValue :: typedSymbol t -> t -> model -> model + + -- | Returns a model that removed all the assignments for the symbolic + -- constants in the set + exceptFor :: symbolSet -> model -> model + + -- | Returns a model that only keeps the assignments for the symbolic + -- constants in the set + restrictTo :: symbolSet -> model -> model + + -- | Returns a model that extends the assignments for the symbolic constants + -- in the set by assigning default values to them + extendTo :: symbolSet -> model -> model + + -- | Returns a model that contains the assignments for exactly the symbolic + -- constants in the set by removing assignments for the symbolic constants that + -- are not in the set and add assignments for the missing symbolic constants + -- by assigning default values to them. + exact :: symbolSet -> model -> model + exact s = restrictTo s . extendTo s + +-- | A type class for building a model manually from a model representation +class ModelOps model symbolSet typedSymbol => ModelRep rep model symbolSet (typedSymbol :: * -> *) where + -- | Build a model + -- + -- >>> let aBool = "a" :: TypedSymbol Bool + -- >>> let bBool = "b" :: TypedSymbol Bool + -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model + -- Model {a -> True :: Bool, b -> False :: Bool} + buildModel :: rep -> model diff --git a/src/Grisette/Core/Data/Class/SOrd.hs b/src/Grisette/Core/Data/Class/SOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/SOrd.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.SOrd +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.SOrd + ( -- * Symbolic total order relation + SOrd (..), + SOrd' (..), + ) +where + +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Word +import Generics.Deriving +import {-# SOURCE #-} Grisette.Core.Control.Monad.UnionM +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Auxiliary class for 'SOrd' instance derivation +class (SEq' f) => SOrd' f where + -- | Auxiliary function for '(<~~) derivation + (<~~) :: f a -> f a -> SymBool + + infix 4 <~~ + + -- | Auxiliary function for '(<=~~) derivation + (<=~~) :: f a -> f a -> SymBool + + infix 4 <=~~ + + -- | Auxiliary function for '(>~~) derivation + (>~~) :: f a -> f a -> SymBool + + infix 4 >~~ + + -- | Auxiliary function for '(>=~~) derivation + (>=~~) :: f a -> f a -> SymBool + + infix 4 >=~~ + + -- | Auxiliary function for 'symCompare' derivation + symCompare' :: f a -> f a -> UnionM Ordering + +instance SOrd' U1 where + _ <~~ _ = con False + _ <=~~ _ = con True + _ >~~ _ = con False + _ >=~~ _ = con True + symCompare' _ _ = mrgSingle EQ + +instance SOrd' V1 where + _ <~~ _ = con False + _ <=~~ _ = con True + _ >~~ _ = con False + _ >=~~ _ = con True + symCompare' _ _ = mrgSingle EQ + +instance (SOrd c) => SOrd' (K1 i c) where + (K1 a) <~~ (K1 b) = a <~ b + (K1 a) <=~~ (K1 b) = a <=~ b + (K1 a) >~~ (K1 b) = a >~ b + (K1 a) >=~~ (K1 b) = a >=~ b + symCompare' (K1 a) (K1 b) = symCompare a b + +instance (SOrd' a) => SOrd' (M1 i c a) where + (M1 a) <~~ (M1 b) = a <~~ b + (M1 a) <=~~ (M1 b) = a <=~~ b + (M1 a) >~~ (M1 b) = a >~~ b + (M1 a) >=~~ (M1 b) = a >=~~ b + symCompare' (M1 a) (M1 b) = symCompare' a b + +instance (SOrd' a, SOrd' b) => SOrd' (a :+: b) where + (L1 _) <~~ (R1 _) = con True + (L1 a) <~~ (L1 b) = a <~~ b + (R1 _) <~~ (L1 _) = con False + (R1 a) <~~ (R1 b) = a <~~ b + (L1 _) <=~~ (R1 _) = con True + (L1 a) <=~~ (L1 b) = a <=~~ b + (R1 _) <=~~ (L1 _) = con False + (R1 a) <=~~ (R1 b) = a <=~~ b + + (L1 _) >~~ (R1 _) = con False + (L1 a) >~~ (L1 b) = a >~~ b + (R1 _) >~~ (L1 _) = con True + (R1 a) >~~ (R1 b) = a >~~ b + (L1 _) >=~~ (R1 _) = con False + (L1 a) >=~~ (L1 b) = a >=~~ b + (R1 _) >=~~ (L1 _) = con True + (R1 a) >=~~ (R1 b) = a >=~~ b + + symCompare' (L1 a) (L1 b) = symCompare' a b + symCompare' (L1 _) (R1 _) = mrgSingle LT + symCompare' (R1 a) (R1 b) = symCompare' a b + symCompare' (R1 _) (L1 _) = mrgSingle GT + +instance (SOrd' a, SOrd' b) => SOrd' (a :*: b) where + (a1 :*: b1) <~~ (a2 :*: b2) = (a1 <~~ a2) ||~ ((a1 ==~~ a2) &&~ (b1 <~~ b2)) + (a1 :*: b1) <=~~ (a2 :*: b2) = (a1 <~~ a2) ||~ ((a1 ==~~ a2) &&~ (b1 <=~~ b2)) + (a1 :*: b1) >~~ (a2 :*: b2) = (a1 >~~ a2) ||~ ((a1 ==~~ a2) &&~ (b1 >~~ b2)) + (a1 :*: b1) >=~~ (a2 :*: b2) = (a1 >~~ a2) ||~ ((a1 ==~~ a2) &&~ (b1 >=~~ b2)) + symCompare' (a1 :*: b1) (a2 :*: b2) = do + l <- symCompare' a1 a2 + case l of + EQ -> symCompare' b1 b2 + _ -> mrgSingle l + +derivedSymLt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymLt x y = from x <~~ from y + +derivedSymLe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymLe x y = from x <=~~ from y + +derivedSymGt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymGt x y = from x >~~ from y + +derivedSymGe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymGe x y = from x >=~~ from y + +derivedSymCompare :: (Generic a, SOrd' (Rep a)) => a -> a -> UnionM Ordering +derivedSymCompare x y = symCompare' (from x) (from y) + +-- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' +-- value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a <~ b +-- true +-- >>> a >~ b +-- false +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a <~ b +-- (< a b) +-- >>> a <=~ b +-- (<= a b) +-- >>> a >~ b +-- (< b a) +-- >>> a >=~ b +-- (<= b a) +-- +-- For `symCompare`, `Ordering` is not a solvable type, and the result would +-- be wrapped in a union-like monad. See `Grisette.Core.Control.Monad.UnionMBase` and `UnionLike` for more +-- information. +-- +-- >>> a `symCompare` b :: UnionM Ordering -- UnionM is UnionMBase specialized with SymBool +-- {If (< a b) LT (If (= a b) EQ GT)} +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SOrd via (Default X) +class (SEq a) => SOrd a where + (<~) :: a -> a -> SymBool + infix 4 <~ + (<=~) :: a -> a -> SymBool + infix 4 <=~ + (>~) :: a -> a -> SymBool + infix 4 >~ + (>=~) :: a -> a -> SymBool + infix 4 >=~ + x <~ y = x <=~ y &&~ x /=~ y + x >~ y = y <~ x + x >=~ y = y <=~ x + symCompare :: a -> a -> UnionM Ordering + symCompare l r = + mrgIf + (l <~ r) + (mrgSingle LT) + (mrgIf (l ==~ r) (mrgSingle EQ) (mrgSingle GT)) + {-# MINIMAL (<=~) #-} + +instance (SEq a, Generic a, SOrd' (Rep a)) => SOrd (Default a) where + (Default l) <=~ (Default r) = l `derivedSymLe` r + (Default l) <~ (Default r) = l `derivedSymLt` r + (Default l) >=~ (Default r) = l `derivedSymGe` r + (Default l) >~ (Default r) = l `derivedSymGt` r + symCompare (Default l) (Default r) = derivedSymCompare l r + +#define CONCRETE_SORD(type) \ +instance SOrd type where \ + l <=~ r = con $ l <= r; \ + l <~ r = con $ l < r; \ + l >=~ r = con $ l >= r; \ + l >~ r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r + +#if 1 +CONCRETE_SORD(Bool) +CONCRETE_SORD(Integer) +CONCRETE_SORD(Char) +CONCRETE_SORD(Int) +CONCRETE_SORD(Int8) +CONCRETE_SORD(Int16) +CONCRETE_SORD(Int32) +CONCRETE_SORD(Int64) +CONCRETE_SORD(Word) +CONCRETE_SORD(Word8) +CONCRETE_SORD(Word16) +CONCRETE_SORD(Word32) +CONCRETE_SORD(Word64) +CONCRETE_SORD(B.ByteString) +#endif + +symCompareSingleList :: (SOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool +symCompareSingleList isLess isStrict = go + where + go [] [] = con (not isStrict) + go (x : xs) (y : ys) = (if isLess then x <~ y else x >~ y) ||~ (x ==~ y &&~ go xs ys) + go [] _ = if isLess then con True else con False + go _ [] = if isLess then con False else con True + +symCompareList :: (SOrd a) => [a] -> [a] -> UnionM Ordering +symCompareList [] [] = mrgSingle EQ +symCompareList (x : xs) (y : ys) = do + oxy <- symCompare x y + case oxy of + LT -> mrgSingle LT + EQ -> symCompareList xs ys + GT -> mrgSingle GT +symCompareList [] _ = mrgSingle LT +symCompareList _ [] = mrgSingle GT + +instance (SOrd a) => SOrd [a] where + (<=~) = symCompareSingleList True False + (<~) = symCompareSingleList True True + (>=~) = symCompareSingleList False False + (>~) = symCompareSingleList False True + symCompare = symCompareList + +deriving via (Default (Maybe a)) instance SOrd a => SOrd (Maybe a) + +deriving via (Default (Either a b)) instance (SOrd a, SOrd b) => SOrd (Either a b) + +deriving via (Default ()) instance SOrd () + +deriving via (Default (a, b)) instance (SOrd a, SOrd b) => SOrd (a, b) + +deriving via (Default (a, b, c)) instance (SOrd a, SOrd b, SOrd c) => SOrd (a, b, c) + +deriving via + (Default (a, b, c, d)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d) => + SOrd (a, b, c, d) + +deriving via + (Default (a, b, c, d, e)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e) => + SOrd (a, b, c, d, e) + +deriving via + (Default (a, b, c, d, e, f)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f) => + SOrd (a, b, c, d, e, f) + +deriving via + (Default (a, b, c, d, e, f, g)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f, SOrd g) => + SOrd (a, b, c, d, e, f, g) + +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( SOrd a, + SOrd b, + SOrd c, + SOrd d, + SOrd e, + SOrd f, + SOrd g, + SOrd h + ) => + SOrd (a, b, c, d, e, f, g, h) + +deriving via + (Default (Sum f g a)) + instance + (SOrd (f a), SOrd (g a)) => SOrd (Sum f g a) + +instance (SOrd (m (Maybe a))) => SOrd (MaybeT m a) where + (MaybeT l) <=~ (MaybeT r) = l <=~ r + (MaybeT l) <~ (MaybeT r) = l <~ r + (MaybeT l) >=~ (MaybeT r) = l >=~ r + (MaybeT l) >~ (MaybeT r) = l >~ r + symCompare (MaybeT l) (MaybeT r) = symCompare l r + +instance (SOrd (m (Either e a))) => SOrd (ExceptT e m a) where + (ExceptT l) <=~ (ExceptT r) = l <=~ r + (ExceptT l) <~ (ExceptT r) = l <~ r + (ExceptT l) >=~ (ExceptT r) = l >=~ r + (ExceptT l) >~ (ExceptT r) = l >~ r + symCompare (ExceptT l) (ExceptT r) = symCompare l r + +instance (SOrd (m (a, s))) => SOrd (WriterLazy.WriterT s m a) where + (WriterLazy.WriterT l) <=~ (WriterLazy.WriterT r) = l <=~ r + (WriterLazy.WriterT l) <~ (WriterLazy.WriterT r) = l <~ r + (WriterLazy.WriterT l) >=~ (WriterLazy.WriterT r) = l >=~ r + (WriterLazy.WriterT l) >~ (WriterLazy.WriterT r) = l >~ r + symCompare (WriterLazy.WriterT l) (WriterLazy.WriterT r) = symCompare l r + +instance (SOrd (m (a, s))) => SOrd (WriterStrict.WriterT s m a) where + (WriterStrict.WriterT l) <=~ (WriterStrict.WriterT r) = l <=~ r + (WriterStrict.WriterT l) <~ (WriterStrict.WriterT r) = l <~ r + (WriterStrict.WriterT l) >=~ (WriterStrict.WriterT r) = l >=~ r + (WriterStrict.WriterT l) >~ (WriterStrict.WriterT r) = l >~ r + symCompare (WriterStrict.WriterT l) (WriterStrict.WriterT r) = symCompare l r + +instance (SOrd a) => SOrd (Identity a) where + (Identity l) <=~ (Identity r) = l <=~ r + (Identity l) <~ (Identity r) = l <~ r + (Identity l) >=~ (Identity r) = l >=~ r + (Identity l) >~ (Identity r) = l >~ r + (Identity l) `symCompare` (Identity r) = l `symCompare` r + +instance (SOrd (m a)) => SOrd (IdentityT m a) where + (IdentityT l) <=~ (IdentityT r) = l <=~ r + (IdentityT l) <~ (IdentityT r) = l <~ r + (IdentityT l) >=~ (IdentityT r) = l >=~ r + (IdentityT l) >~ (IdentityT r) = l >~ r + (IdentityT l) `symCompare` (IdentityT r) = l `symCompare` r diff --git a/src/Grisette/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Core/Data/Class/SimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/SimpleMergeable.hs @@ -0,0 +1,775 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Core.Data.Class.SimpleMergeable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.SimpleMergeable + ( -- * Simple mergeable types + SimpleMergeable (..), + SimpleMergeable1 (..), + mrgIte1, + SimpleMergeable2 (..), + mrgIte2, + + -- * UnionLike operations + UnionLike (..), + mrgIf, + merge, + mrgSingle, + UnionPrjOp (..), + pattern SingleU, + pattern IfU, + simpleMerge, + onUnion, + onUnion2, + onUnion3, + onUnion4, + (#~), + ) +where + +import Control.Monad.Except +import Control.Monad.Identity +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Kind +import GHC.Generics +import Generics.Deriving +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Function +import Grisette.Core.Data.Class.Mergeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> import Control.Monad.Identity + +-- | Auxiliary class for the generic derivation for the 'SimpleMergeable' class. +class SimpleMergeable' f where + mrgIte' :: SymBool -> f a -> f a -> f a + +instance (SimpleMergeable' U1) where + mrgIte' _ t _ = t + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable' V1) where + mrgIte' _ t _ = t + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable c) => (SimpleMergeable' (K1 i c)) where + mrgIte' cond (K1 a) (K1 b) = K1 $ mrgIte cond a b + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable' a) => (SimpleMergeable' (M1 i c a)) where + mrgIte' cond (M1 a) (M1 b) = M1 $ mrgIte' cond a b + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable' a, SimpleMergeable' b) => (SimpleMergeable' (a :*: b)) where + mrgIte' cond (a1 :*: a2) (b1 :*: b2) = mrgIte' cond a1 b1 :*: mrgIte' cond a2 b2 + {-# INLINE mrgIte' #-} + +-- | This class indicates that a type has a simple root merge strategy. +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... +-- > deriving Generic +-- > deriving (Mergeable, SimpleMergeable) via (Default X) +class Mergeable a => SimpleMergeable a where + -- | Performs if-then-else with the simple root merge strategy. + -- + -- >>> mrgIte "a" "b" "c" :: SymInteger + -- (ite a b c) + mrgIte :: SymBool -> a -> a -> a + +instance (Generic a, Mergeable' (Rep a), SimpleMergeable' (Rep a)) => SimpleMergeable (Default a) where + mrgIte cond (Default a) (Default b) = Default $ to $ mrgIte' cond (from a) (from b) + {-# INLINE mrgIte #-} + +-- | Lifting of the 'SimpleMergeable' class to unary type constructors. +class SimpleMergeable1 u where + -- | Lift 'mrgIte' through the type constructor. + -- + -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger + -- Identity (ite a b c) + liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a + +-- | Lift the standard 'mrgIte' function through the type constructor. +-- +-- >>> mrgIte1 "a" (Identity "b") (Identity "c") :: Identity SymInteger +-- Identity (ite a b c) +mrgIte1 :: (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a +mrgIte1 = liftMrgIte mrgIte +{-# INLINE mrgIte1 #-} + +-- | Lifting of the 'SimpleMergeable' class to binary type constructors. +class (Mergeable2 u) => SimpleMergeable2 u where + -- | Lift 'mrgIte' through the type constructor. + -- + -- >>> liftMrgIte2 mrgIte mrgIte "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) + -- ((ite a b d),(ite a c e)) + liftMrgIte2 :: (SymBool -> a -> a -> a) -> (SymBool -> b -> b -> b) -> SymBool -> u a b -> u a b -> u a b + +-- | Lift the standard 'mrgIte' function through the type constructor. +-- +-- >>> mrgIte2 "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) +-- ((ite a b d),(ite a c e)) +mrgIte2 :: (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => SymBool -> u a b -> u a b -> u a b +mrgIte2 = liftMrgIte2 mrgIte mrgIte +{-# INLINE mrgIte2 #-} + +-- | Special case of the 'Mergeable1' and 'SimpleMergeable1' class for type +-- constructors that are 'SimpleMergeable' when applied to any 'Mergeable' +-- types. +-- +-- This type class is used to generalize the 'mrgIf' function to other +-- containers, for example, monad transformer transformed Unions. +class (SimpleMergeable1 u, Mergeable1 u) => UnionLike u where + -- | Wrap a single value in the union. + -- + -- Note that this function cannot propagate the 'Mergeable' knowledge. + -- + -- >>> single "a" :: UnionM SymInteger + -- + -- >>> mrgSingle "a" :: UnionM SymInteger + -- {a} + single :: a -> u a + + -- | If-then-else on two union values. + -- + -- Note that this function cannot capture the 'Mergeable' knowledge. However, + -- it may use the merging strategy from the branches to merge the results. + -- + -- >>> unionIf "a" (single "b") (single "c") :: UnionM SymInteger + -- + -- >>> unionIf "a" (mrgSingle "b") (single "c") :: UnionM SymInteger + -- {(ite a b c)} + unionIf :: SymBool -> u a -> u a -> u a + + -- | Merge the contents with some merge strategy. + -- + -- >>> mergeWithStrategy rootStrategy $ unionIf "a" (single "b") (single "c") :: UnionM SymInteger + -- {(ite a b c)} + -- + -- __Note:__ Be careful to call this directly in your code. + -- The supplied merge strategy should be consistent with the type's root merge strategy, + -- or some internal invariants would be broken and the program can crash. + -- + -- This function is to be called when the 'Mergeable' constraint can not be resolved, + -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. + -- In other cases, 'merge' is usually a better alternative. + mergeWithStrategy :: MergingStrategy a -> u a -> u a + + -- | Symbolic @if@ control flow with the result merged with some merge strategy. + -- + -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (single "c") :: UnionM SymInteger + -- {(ite a b c)} + -- + -- __Note:__ Be careful to call this directly in your code. + -- The supplied merge strategy should be consistent with the type's root merge strategy, + -- or some internal invariants would be broken and the program can crash. + -- + -- This function is to be called when the 'Mergeable' constraint can not be resolved, + -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. + -- In other cases, 'mrgIf' is usually a better alternative. + mrgIfWithStrategy :: MergingStrategy a -> SymBool -> u a -> u a -> u a + mrgIfWithStrategy s cond l r = mergeWithStrategy s $ unionIf cond l r + {-# INLINE mrgIfWithStrategy #-} + + -- | Wrap a single value in the union and capture the 'Mergeable' knowledge. + -- + -- >>> mrgSingleWithStrategy rootStrategy "a" :: UnionM SymInteger + -- {a} + -- + -- __Note:__ Be careful to call this directly in your code. + -- The supplied merge strategy should be consistent with the type's root merge strategy, + -- or some internal invariants would be broken and the program can crash. + -- + -- This function is to be called when the 'Mergeable' constraint can not be resolved, + -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. + -- In other cases, 'mrgSingle' is usually a better alternative. + mrgSingleWithStrategy :: MergingStrategy a -> a -> u a + mrgSingleWithStrategy s = mergeWithStrategy s . single + {-# INLINE mrgSingleWithStrategy #-} + +-- | Symbolic @if@ control flow with the result merged with the type's root merge strategy. +-- +-- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@. +-- +-- >>> mrgIf "a" (single "b") (single "c") :: UnionM SymInteger +-- {(ite a b c)} +mrgIf :: (UnionLike u, Mergeable a) => SymBool -> u a -> u a -> u a +mrgIf = mrgIfWithStrategy rootStrategy +{-# INLINE mrgIf #-} + +-- | Merge the contents with the type's root merge strategy. +-- +-- Equivalent to @'mergeWithStrategy' 'rootStrategy'@. +-- +-- >>> merge $ unionIf "a" (single "b") (single "c") :: UnionM SymInteger +-- {(ite a b c)} +merge :: (UnionLike u, Mergeable a) => u a -> u a +merge = mergeWithStrategy rootStrategy +{-# INLINE merge #-} + +-- | Wrap a single value in the type and propagate the type's root merge strategy. +-- +-- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@. +-- +-- >>> mrgSingle "a" :: UnionM SymInteger +-- {a} +mrgSingle :: (UnionLike u, Mergeable a) => a -> u a +mrgSingle = mrgSingleWithStrategy rootStrategy +{-# INLINE mrgSingle #-} + +instance SimpleMergeable () where + mrgIte _ t _ = t + {-# INLINE mrgIte #-} + +instance (SimpleMergeable a, SimpleMergeable b) => SimpleMergeable (a, b) where + mrgIte cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mrgIte cond b1 b2) + {-# INLINE mrgIte #-} + +instance (SimpleMergeable a) => SimpleMergeable1 ((,) a) where + liftMrgIte mb cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mb cond b1 b2) + {-# INLINE liftMrgIte #-} + +instance SimpleMergeable2 (,) where + liftMrgIte2 ma mb cond (a1, b1) (a2, b2) = (ma cond a1 a2, mb cond b1 b2) + {-# INLINE liftMrgIte2 #-} + +instance + (SimpleMergeable a, SimpleMergeable b, SimpleMergeable c) => + SimpleMergeable (a, b, c) + where + mrgIte cond (a1, b1, c1) (a2, b2, c2) = (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d + ) => + SimpleMergeable (a, b, c, d) + where + mrgIte cond (a1, b1, c1, d1) (a2, b2, c2, d2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e + ) => + SimpleMergeable (a, b, c, d, e) + where + mrgIte cond (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e, + SimpleMergeable f + ) => + SimpleMergeable (a, b, c, d, e, f) + where + mrgIte cond (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2, mrgIte cond f1 f2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e, + SimpleMergeable f, + SimpleMergeable g + ) => + SimpleMergeable (a, b, c, d, e, f, g) + where + mrgIte cond (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) = + ( mrgIte cond a1 a2, + mrgIte cond b1 b2, + mrgIte cond c1 c2, + mrgIte cond d1 d2, + mrgIte cond e1 e2, + mrgIte cond f1 f2, + mrgIte cond g1 g2 + ) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e, + SimpleMergeable f, + SimpleMergeable g, + SimpleMergeable h + ) => + SimpleMergeable (a, b, c, d, e, f, g, h) + where + mrgIte cond (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) = + ( mrgIte cond a1 a2, + mrgIte cond b1 b2, + mrgIte cond c1 c2, + mrgIte cond d1 d2, + mrgIte cond e1 e2, + mrgIte cond f1 f2, + mrgIte cond g1 g2, + mrgIte cond h1 h2 + ) + {-# INLINE mrgIte #-} + +instance SimpleMergeable b => SimpleMergeable (a -> b) where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 ((->) a) where + liftMrgIte ms cond t f v = ms cond (t v) (f v) + {-# INLINE liftMrgIte #-} + +instance (UnionLike m, Mergeable a) => SimpleMergeable (MaybeT m a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance (UnionLike m) => SimpleMergeable1 (MaybeT m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (UnionLike m) => UnionLike (MaybeT m) where + mergeWithStrategy s (MaybeT v) = MaybeT $ mergeWithStrategy (liftRootStrategy s) v + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (MaybeT t) (MaybeT f) = MaybeT $ mrgIfWithStrategy (liftRootStrategy s) cond t f + {-# INLINE mrgIfWithStrategy #-} + single = MaybeT . single . return + {-# INLINE single #-} + unionIf cond (MaybeT l) (MaybeT r) = MaybeT $ unionIf cond l r + {-# INLINE unionIf #-} + +instance + (UnionLike m, Mergeable e, Mergeable a) => + SimpleMergeable (ExceptT e m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (UnionLike m, Mergeable e) => + SimpleMergeable1 (ExceptT e m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (UnionLike m, Mergeable e) => + UnionLike (ExceptT e m) + where + mergeWithStrategy s (ExceptT v) = ExceptT $ mergeWithStrategy (liftRootStrategy s) v + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f + {-# INLINE mrgIfWithStrategy #-} + single = ExceptT . single . return + {-# INLINE single #-} + unionIf cond (ExceptT l) (ExceptT r) = ExceptT $ unionIf cond l r + {-# INLINE unionIf #-} + +instance + (Mergeable s, Mergeable a, UnionLike m) => + SimpleMergeable (StateLazy.StateT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionLike m) => + SimpleMergeable1 (StateLazy.StateT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionLike m) => + UnionLike (StateLazy.StateT s m) + where + mergeWithStrategy ms (StateLazy.StateT f) = + StateLazy.StateT $ \v -> mergeWithStrategy (liftRootStrategy2 ms rootStrategy) $ f v + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) = + StateLazy.StateT $ \v -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + single x = StateLazy.StateT $ \s -> single (x, s) + {-# INLINE single #-} + unionIf cond (StateLazy.StateT l) (StateLazy.StateT r) = + StateLazy.StateT $ \s -> unionIf cond (l s) (r s) + {-# INLINE unionIf #-} + +instance + (Mergeable s, Mergeable a, UnionLike m) => + SimpleMergeable (StateStrict.StateT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionLike m) => + SimpleMergeable1 (StateStrict.StateT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionLike m) => + UnionLike (StateStrict.StateT s m) + where + mergeWithStrategy ms (StateStrict.StateT f) = + StateStrict.StateT $ \v -> mergeWithStrategy (liftRootStrategy2 ms rootStrategy) $ f v + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) = + StateStrict.StateT $ \v -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + single x = StateStrict.StateT $ \s -> single (x, s) + {-# INLINE single #-} + unionIf cond (StateStrict.StateT l) (StateStrict.StateT r) = + StateStrict.StateT $ \s -> unionIf cond (l s) (r s) + {-# INLINE unionIf #-} + +instance + (Mergeable s, Mergeable a, UnionLike m, Monoid s) => + SimpleMergeable (WriterLazy.WriterT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionLike m, Monoid s) => + SimpleMergeable1 (WriterLazy.WriterT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionLike m, Monoid s) => + UnionLike (WriterLazy.WriterT s m) + where + mergeWithStrategy ms (WriterLazy.WriterT f) = WriterLazy.WriterT $ mergeWithStrategy (liftRootStrategy2 ms rootStrategy) f + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = + WriterLazy.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f + {-# INLINE mrgIfWithStrategy #-} + single x = WriterLazy.WriterT $ single (x, mempty) + {-# INLINE single #-} + unionIf cond (WriterLazy.WriterT l) (WriterLazy.WriterT r) = + WriterLazy.WriterT $ unionIf cond l r + {-# INLINE unionIf #-} + +instance + (Mergeable s, Mergeable a, UnionLike m, Monoid s) => + SimpleMergeable (WriterStrict.WriterT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionLike m, Monoid s) => + SimpleMergeable1 (WriterStrict.WriterT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionLike m, Monoid s) => + UnionLike (WriterStrict.WriterT s m) + where + mergeWithStrategy ms (WriterStrict.WriterT f) = WriterStrict.WriterT $ mergeWithStrategy (liftRootStrategy2 ms rootStrategy) f + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = + WriterStrict.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f + {-# INLINE mrgIfWithStrategy #-} + single x = WriterStrict.WriterT $ single (x, mempty) + {-# INLINE single #-} + unionIf cond (WriterStrict.WriterT l) (WriterStrict.WriterT r) = + WriterStrict.WriterT $ unionIf cond l r + {-# INLINE unionIf #-} + +instance + (Mergeable a, UnionLike m) => + SimpleMergeable (ReaderT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (UnionLike m) => + SimpleMergeable1 (ReaderT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (UnionLike m) => + UnionLike (ReaderT s m) + where + mergeWithStrategy ms (ReaderT f) = ReaderT $ \v -> mergeWithStrategy ms $ f v + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) = + ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + single x = ReaderT $ \_ -> single x + {-# INLINE single #-} + unionIf cond (ReaderT l) (ReaderT r) = ReaderT $ \s -> unionIf cond (l s) (r s) + {-# INLINE unionIf #-} + +instance (SimpleMergeable a) => SimpleMergeable (Identity a) where + mrgIte cond (Identity l) (Identity r) = Identity $ mrgIte cond l r + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 Identity where + liftMrgIte mite cond (Identity l) (Identity r) = Identity $ mite cond l r + {-# INLINE liftMrgIte #-} + +instance (UnionLike m, Mergeable a) => SimpleMergeable (IdentityT m a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance (UnionLike m) => SimpleMergeable1 (IdentityT m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (UnionLike m) => UnionLike (IdentityT m) where + mergeWithStrategy ms (IdentityT f) = + IdentityT $ mergeWithStrategy ms f + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = IdentityT $ mrgIfWithStrategy s cond l r + {-# INLINE mrgIfWithStrategy #-} + single x = IdentityT $ single x + {-# INLINE single #-} + unionIf cond (IdentityT l) (IdentityT r) = IdentityT $ unionIf cond l r + {-# INLINE unionIf #-} + +instance (UnionLike m, Mergeable r) => SimpleMergeable (ContT r m a) where + mrgIte cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) + {-# INLINE mrgIte #-} + +instance (UnionLike m, Mergeable r) => SimpleMergeable1 (ContT r m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (UnionLike m, Mergeable r) => UnionLike (ContT r m) where + mergeWithStrategy _ (ContT f) = ContT $ \c -> merge (f c) + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy _ cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) + {-# INLINE mrgIfWithStrategy #-} + single x = ContT $ \c -> c x + {-# INLINE single #-} + unionIf cond (ContT l) (ContT r) = ContT $ \c -> unionIf cond (l c) (r c) + {-# INLINE unionIf #-} + +instance + (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionLike m) => + SimpleMergeable (RWSLazy.RWST r w s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionLike m) => + SimpleMergeable1 (RWSLazy.RWST r w s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionLike m) => + UnionLike (RWSLazy.RWST r w s m) + where + mergeWithStrategy ms (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> mergeWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) $ f r s + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> mrgIfWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) cond (t r s) (f r s) + {-# INLINE mrgIfWithStrategy #-} + single x = RWSLazy.RWST $ \_ s -> single (x, s, mempty) + {-# INLINE single #-} + unionIf cond (RWSLazy.RWST t) (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> unionIf cond (t r s) (f r s) + {-# INLINE unionIf #-} + +instance + (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionLike m) => + SimpleMergeable (RWSStrict.RWST r w s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionLike m) => + SimpleMergeable1 (RWSStrict.RWST r w s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionLike m) => + UnionLike (RWSStrict.RWST r w s m) + where + mergeWithStrategy ms (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> mergeWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) $ f r s + {-# INLINE mergeWithStrategy #-} + mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> mrgIfWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) cond (t r s) (f r s) + {-# INLINE mrgIfWithStrategy #-} + single x = RWSStrict.RWST $ \_ s -> single (x, s, mempty) + {-# INLINE single #-} + unionIf cond (RWSStrict.RWST t) (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> unionIf cond (t r s) (f r s) + {-# INLINE unionIf #-} + +-- | Union containers that can be projected back into single value or +-- if-guarded values. +class (UnionLike u) => UnionPrjOp (u :: Type -> Type) where + -- | Pattern match to extract single values. + -- + -- >>> singleView (single 1 :: UnionM Integer) + -- Just 1 + -- >>> singleView (unionIf "a" (single 1) (single 2) :: UnionM Integer) + -- Nothing + singleView :: u a -> Maybe a + + -- | Pattern match to extract if values. + -- + -- >>> ifView (single 1 :: UnionM Integer) + -- Nothing + -- >>> ifView (unionIf "a" (single 1) (single 2) :: UnionM Integer) + -- Just (a,<1>,<2>) + -- >>> ifView (mrgIf "a" (single 1) (single 2) :: UnionM Integer) + -- Just (a,{1},{2}) + ifView :: u a -> Maybe (SymBool, u a, u a) + + -- | The leftmost value in the union. + -- + -- >>> leftMost (unionIf "a" (single 1) (single 2) :: UnionM Integer) + -- 1 + leftMost :: u a -> a + +-- | Pattern match to extract single values with 'singleView'. +-- +-- >>> case (single 1 :: UnionM Integer) of SingleU v -> v +-- 1 +pattern SingleU :: UnionPrjOp u => a -> u a +pattern SingleU x <- + (singleView -> Just x) + where + SingleU x = single x + +-- | Pattern match to extract guard values with 'ifView' +-- >>> case (unionIf "a" (single 1) (single 2) :: UnionM Integer) of IfU c t f -> (c,t,f) +-- (a,<1>,<2>) +pattern IfU :: UnionPrjOp u => SymBool -> u a -> u a -> u a +pattern IfU c t f <- + (ifView -> Just (c, t, f)) + where + IfU c t f = unionIf c t f + +-- | Merge the simply mergeable values in a union, and extract the merged value. +-- +-- In the following example, 'unionIf' will not merge the results, and +-- 'simpleMerge' will merge it and extract the single merged value. +-- +-- >>> unionIf (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool +-- +-- >>> simpleMerge $ (unionIf (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool) +-- (ite a b c) +simpleMerge :: forall bool u a. (SimpleMergeable a, UnionLike u, UnionPrjOp u) => u a -> a +simpleMerge u = case merge u of + SingleU x -> x + _ -> error "Should not happen" +{-# INLINE simpleMerge #-} + +-- | Lift a function to work on union values. +-- +-- >>> sumU = onUnion sum +-- >>> sumU (unionIf "cond" (return ["a"]) (return ["b","c"]) :: UnionM [SymInteger]) +-- (ite cond a (+ b c)) +onUnion :: + forall bool u a r. + (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => + (a -> r) -> + (u a -> r) +onUnion f = simpleMerge . fmap f + +-- | Lift a function to work on union values. +onUnion2 :: + forall bool u a b r. + (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => + (a -> b -> r) -> + (u a -> u b -> r) +onUnion2 f ua ub = simpleMerge $ f <$> ua <*> ub + +-- | Lift a function to work on union values. +onUnion3 :: + forall bool u a b c r. + (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => + (a -> b -> c -> r) -> + (u a -> u b -> u c -> r) +onUnion3 f ua ub uc = simpleMerge $ f <$> ua <*> ub <*> uc + +-- | Lift a function to work on union values. +onUnion4 :: + forall bool u a b c d r. + (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => + (a -> b -> c -> d -> r) -> + (u a -> u b -> u c -> u d -> r) +onUnion4 f ua ub uc ud = simpleMerge $ f <$> ua <*> ub <*> uc <*> ud + +-- | Helper for applying functions on 'UnionPrjOp' and 'SimpleMergeable'. +-- +-- >>> let f :: Integer -> UnionM Integer = \x -> mrgIf (ssym "a") (mrgSingle $ x + 1) (mrgSingle $ x + 2) +-- >>> f #~ (mrgIf (ssym "b" :: SymBool) (mrgSingle 0) (mrgSingle 2) :: UnionM Integer) +-- {If (&& b a) 1 (If b 2 (If a 3 4))} +(#~) :: + (Function f, SimpleMergeable (Ret f), UnionPrjOp u, Functor u) => + f -> + u (Arg f) -> + Ret f +(#~) f u = simpleMerge $ fmap (f #) u +{-# INLINE (#~) #-} + +infixl 9 #~ + +instance (SupportedPrim a) => SimpleMergeable (Sym a) where + mrgIte = ites diff --git a/src/Grisette/Core/Data/Class/SimpleMergeable.hs-boot b/src/Grisette/Core/Data/Class/SimpleMergeable.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/SimpleMergeable.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} + +module Grisette.Core.Data.Class.SimpleMergeable (SimpleMergeable (..)) where + +import {-# SOURCE #-} Grisette.Core.Data.Class.Mergeable +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +class Mergeable a => SimpleMergeable a where + mrgIte :: SymBool -> a -> a -> a diff --git a/src/Grisette/Core/Data/Class/Solvable.hs b/src/Grisette/Core/Data/Class/Solvable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Solvable.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Core.Data.Class.Solvable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Solvable + ( -- * Solvable type interface + Solvable (..), + pattern Con, + ) +where + +import Control.DeepSeq +import Data.Hashable +import Data.String +import Data.Typeable +import Language.Haskell.TH.Syntax + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | The class defines the creation and pattern matching of solvable type +-- values. +class IsString t => Solvable c t | t -> c where + -- | Wrap a concrete value in a symbolic value. + -- + -- >>> con True :: SymBool + -- true + con :: c -> t + + -- | Extract the concrete value from a symbolic value. + -- + -- >>> conView (con True :: SymBool) + -- Just True + -- + -- >>> conView (ssym "a" :: SymBool) + -- Nothing + conView :: t -> Maybe c + + -- | Generate simply-named symbolic constants. + -- + -- Two symbolic constants with the same name are the same symbolic constant, + -- and will always be assigned with the same value by the solver. + -- + -- >>> ssym "a" :: SymBool + -- a + -- >>> (ssym "a" :: SymBool) == ssym "a" + -- True + -- >>> (ssym "a" :: SymBool) == ssym "b" + -- False + -- >>> (ssym "a" :: SymBool) &&~ ssym "a" + -- a + ssym :: String -> t + + -- | Generate indexed symbolic constants. + -- + -- Two symbolic constants with the same name but different indices are + -- not the same symbolic constants. + -- + -- >>> isym "a" 1 :: SymBool + -- a@1 + isym :: String -> Int -> t + + -- | Generate simply-named symbolic constants with some extra information for + -- disambiguation. + -- + -- Two symbolic constants with the same name but different extra information + -- (including info with different types) are considered to be different. + -- + -- >>> sinfosym "a" "someInfo" :: SymInteger + -- a:"someInfo" + sinfosym :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => String -> a -> t + + -- | Generate indexed symbolic constants with some extra information for + -- disambiguation. + -- + -- Two symbolic constants with the same name and index but different extra + -- information (including info with different types) are considered to be + -- different. + -- + -- >>> iinfosym "a" 1 "someInfo" :: SymInteger + -- a@1:"someInfo" + iinfosym :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => String -> Int -> a -> t + +-- | Extract the concrete value from a solvable value with 'conView'. +-- +-- >>> case con True :: SymBool of Con v -> v +-- True +pattern Con :: Solvable c t => c -> t +pattern Con c <- + (conView -> Just c) + where + Con c = con c diff --git a/src/Grisette/Core/Data/Class/Solver.hs b/src/Grisette/Core/Data/Class/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Solver.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.Solver +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Solver + ( -- * Note for the examples + + -- + + -- | The examples assumes a [z3](https://github.com/Z3Prover/z3) solver available in @PATH@. + + -- * Union with exceptions + UnionWithExcept (..), + + -- * Solver interfaces + Solver (..), + solveExcept, + solveMultiExcept, + ) +where + +import Control.DeepSeq +import Control.Monad.Except +import Data.Hashable +import Generics.Deriving +import Grisette.Core.Control.Exception +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.IR.SymPrim.Data.Prim.Model +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim +import Language.Haskell.TH.Syntax + +data SolveInternal = SolveInternal deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.Backend.SBV +-- >>> :set -XOverloadedStrings + +-- | A solver interface. +class + Solver config failure + | config -> failure + where + -- | Solve a single formula. Find an assignment to it to make it true. + -- + -- >>> solve (UnboundedReasoning z3) ("a" &&~ ("b" :: SymInteger) ==~ 1) + -- Right (Model {a -> True :: Bool, b -> 1 :: Integer}) + -- >>> solve (UnboundedReasoning z3) ("a" &&~ nots "a") + -- Left Unsat + solve :: + -- | solver configuration + config -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO (Either failure Model) + + -- | Solve a single formula while returning multiple models to make it true. + -- The maximum number of desired models are given. + -- + -- > >>> solveMulti (UnboundedReasoning z3) 4 ("a" ||~ "b") + -- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] + solveMulti :: + -- | solver configuration + config -> + -- | maximum number of models to return + Int -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO [Model] + + -- | Solve a single formula while returning multiple models to make it true. + -- All models are returned. + -- + -- > >>> solveAll (UnboundedReasoning z3) ("a" ||~ "b") + -- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] + solveAll :: + -- | solver configuration + config -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO [Model] + +-- | A class that abstracts the union-like structures that contains exceptions. +class UnionWithExcept t u e v | t -> u e v where + -- | Extract a union of exceptions and values from the structure. + extractUnionExcept :: t -> u (Either e v) + +instance UnionWithExcept (ExceptT e u v) u e v where + extractUnionExcept = runExceptT + +-- | +-- Solver procedure for programs with error handling. +-- +-- >>> :set -XLambdaCase +-- >>> import Control.Monad.Except +-- >>> let x = "x" :: SymInteger +-- >>> :{ +-- res :: ExceptT AssertionError UnionM () +-- res = do +-- symAssert $ x >~ 0 -- constrain that x is positive +-- symAssert $ x <~ 2 -- constrain that x is less than 2 +-- :} +-- +-- >>> :{ +-- translate (Left _) = con False -- errors are not desirable +-- translate _ = con True -- non-errors are desirable +-- :} +-- +-- >>> solveExcept (UnboundedReasoning z3) translate res +-- Right (Model {x -> 1 :: Integer}) +solveExcept :: + ( UnionWithExcept t u e v, + UnionPrjOp u, + Functor u, + Solver config failure + ) => + -- | solver configuration + config -> + -- | mapping the results to symbolic boolean formulas, the solver would try to find a model to make the formula true + (Either e v -> SymBool) -> + -- | the program to be solved, should be a union of exception and values + t -> + IO (Either failure Model) +solveExcept config f v = solve config (simpleMerge $ f <$> extractUnionExcept v) + +-- | +-- Solver procedure for programs with error handling. Would return multiple +-- models if possible. +solveMultiExcept :: + ( UnionWithExcept t u e v, + UnionPrjOp u, + Functor u, + Solver config failure + ) => + -- | solver configuration + config -> + -- | maximum number of models to return + Int -> + -- | mapping the results to symbolic boolean formulas, the solver would try to find a model to make the formula true + (Either e v -> SymBool) -> + -- | the program to be solved, should be a union of exception and values + t -> + IO [Model] +solveMultiExcept config n f v = solveMulti config n (simpleMerge $ f <$> extractUnionExcept v) diff --git a/src/Grisette/Core/Data/Class/Substitute.hs b/src/Grisette/Core/Data/Class/Substitute.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/Substitute.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.Substitute +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.Substitute + ( -- * Substituting symbolic constants + SubstituteSym (..), + SubstituteSym' (..), + ) +where + +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Word +import Generics.Deriving +import Generics.Deriving.Instances () +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | Substitution of symbolic constants. +-- +-- >>> a = "a" :: TypedSymbol Bool +-- >>> v = "x" &&~ "y" :: SymBool +-- >>> substituteSym a v (["a" &&~ "b", "a"] :: [SymBool]) +-- [(&& (&& x y) b),(&& x y)] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SubstituteSym via (Default X) +class SubstituteSym a where + -- Substitute a symbolic constant to some symbolic value + -- + -- >>> substituteSym "a" ("c" &&~ "d" :: Sym Bool) ["a" &&~ "b" :: Sym Bool, "a"] + -- [(&& (&& c d) b),(&& c d)] + substituteSym :: TypedSymbol b -> Sym b -> a -> a + +-- | Auxiliary class for 'SubstituteSym' instance derivation +class SubstituteSym' a where + -- | Auxiliary function for 'substituteSym' derivation + substituteSym' :: TypedSymbol b -> Sym b -> a c -> a c + +instance + ( Generic a, + SubstituteSym' (Rep a) + ) => + SubstituteSym (Default a) + where + substituteSym sym val = Default . to . substituteSym' sym val . from . unDefault + +instance SubstituteSym' U1 where + substituteSym' _ _ = id + +instance SubstituteSym c => SubstituteSym' (K1 i c) where + substituteSym' sym val (K1 v) = K1 $ substituteSym sym val v + +instance SubstituteSym' a => SubstituteSym' (M1 i c a) where + substituteSym' sym val (M1 v) = M1 $ substituteSym' sym val v + +instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :+: b) where + substituteSym' sym val (L1 l) = L1 $ substituteSym' sym val l + substituteSym' sym val (R1 r) = R1 $ substituteSym' sym val r + +instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :*: b) where + substituteSym' sym val (a :*: b) = substituteSym' sym val a :*: substituteSym' sym val b + +#define CONCRETE_SUBSTITUTESYM(type) \ +instance SubstituteSym type where \ + substituteSym _ _ = id + +#if 1 +CONCRETE_SUBSTITUTESYM(Bool) +CONCRETE_SUBSTITUTESYM(Integer) +CONCRETE_SUBSTITUTESYM(Char) +CONCRETE_SUBSTITUTESYM(Int) +CONCRETE_SUBSTITUTESYM(Int8) +CONCRETE_SUBSTITUTESYM(Int16) +CONCRETE_SUBSTITUTESYM(Int32) +CONCRETE_SUBSTITUTESYM(Int64) +CONCRETE_SUBSTITUTESYM(Word) +CONCRETE_SUBSTITUTESYM(Word8) +CONCRETE_SUBSTITUTESYM(Word16) +CONCRETE_SUBSTITUTESYM(Word32) +CONCRETE_SUBSTITUTESYM(Word64) +CONCRETE_SUBSTITUTESYM(B.ByteString) +#endif + +instance SubstituteSym () where + substituteSym _ _ = id + +-- Either +deriving via + (Default (Either a b)) + instance + ( SubstituteSym a, + SubstituteSym b + ) => + SubstituteSym (Either a b) + +-- Maybe +deriving via (Default (Maybe a)) instance (SubstituteSym a) => SubstituteSym (Maybe a) + +-- List +deriving via (Default [a]) instance (SubstituteSym a) => SubstituteSym [a] + +-- (,) +deriving via + (Default (a, b)) + instance + (SubstituteSym a, SubstituteSym b) => + SubstituteSym (a, b) + +-- (,,) +deriving via + (Default (a, b, c)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c + ) => + SubstituteSym (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d + ) => + SubstituteSym (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e + ) => + SubstituteSym (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e, + SubstituteSym f + ) => + SubstituteSym (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e, + SubstituteSym f, + SubstituteSym g + ) => + SubstituteSym (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e, + SubstituteSym f, + SubstituteSym g, + SubstituteSym h + ) => + SubstituteSym ((,,,,,,,) a b c d e f g h) + +-- MaybeT +instance + (SubstituteSym (m (Maybe a))) => + SubstituteSym (MaybeT m a) + where + substituteSym sym val (MaybeT v) = MaybeT $ substituteSym sym val v + +-- ExceptT +instance + (SubstituteSym (m (Either e a))) => + SubstituteSym (ExceptT e m a) + where + substituteSym sym val (ExceptT v) = ExceptT $ substituteSym sym val v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (SubstituteSym (f a), SubstituteSym (g a)) => + SubstituteSym (Sum f g a) + +-- WriterT +instance + (SubstituteSym (m (a, s))) => + SubstituteSym (WriterLazy.WriterT s m a) + where + substituteSym sym val (WriterLazy.WriterT v) = WriterLazy.WriterT $ substituteSym sym val v + +instance + (SubstituteSym (m (a, s))) => + SubstituteSym (WriterStrict.WriterT s m a) + where + substituteSym sym val (WriterStrict.WriterT v) = WriterStrict.WriterT $ substituteSym sym val v + +-- Identity +instance SubstituteSym a => SubstituteSym (Identity a) where + substituteSym sym val (Identity a) = Identity $ substituteSym sym val a + +-- IdentityT +instance SubstituteSym (m a) => SubstituteSym (IdentityT m a) where + substituteSym sym val (IdentityT a) = IdentityT $ substituteSym sym val a + +instance SubstituteSym (Sym a) where + substituteSym sym (Sym val) (Sym x) = + introSupportedPrimConstraint val $ + introSupportedPrimConstraint x $ + Sym $ + substTerm sym val x diff --git a/src/Grisette/Core/Data/Class/ToCon.hs b/src/Grisette/Core/Data/Class/ToCon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/ToCon.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.ToCon +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.ToCon + ( -- * Converting to concrete values + ToCon (..), + ) +where + +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Word +import GHC.Generics +import Generics.Deriving +import Generics.Deriving.Instances () + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | Convert a symbolic value to concrete value if possible. +class ToCon a b where + -- | Convert a symbolic value to concrete value if possible. + -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'. + -- + -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer + -- Nothing + -- + -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer + -- Just 1 + -- + -- 'toCon' works on complex types too. + -- + -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer] + -- Just [1,2] + -- + -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer] + -- Nothing + toCon :: a -> Maybe b + +instance (Generic a, Generic b, ToCon' (Rep a) (Rep b)) => ToCon a (Default b) where + toCon v = fmap (Default . to) $ toCon' $ from v + +class ToCon' a b where + toCon' :: a c -> Maybe (b c) + +instance ToCon' U1 U1 where + toCon' = Just + +instance ToCon a b => ToCon' (K1 i a) (K1 i b) where + toCon' (K1 a) = K1 <$> toCon a + +instance ToCon' a b => ToCon' (M1 i c1 a) (M1 i c2 b) where + toCon' (M1 a) = M1 <$> toCon' a + +instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :+: b1) (a2 :+: b2) where + toCon' (L1 a) = L1 <$> toCon' a + toCon' (R1 a) = R1 <$> toCon' a + +instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :*: b1) (a2 :*: b2) where + toCon' (a :*: b) = do + ac <- toCon' a + bc <- toCon' b + return $ ac :*: bc + +#define CONCRETE_TOCON(type) \ +instance ToCon type type where \ + toCon = Just + +#if 1 +CONCRETE_TOCON(Bool) +CONCRETE_TOCON(Integer) +CONCRETE_TOCON(Char) +CONCRETE_TOCON(Int) +CONCRETE_TOCON(Int8) +CONCRETE_TOCON(Int16) +CONCRETE_TOCON(Int32) +CONCRETE_TOCON(Int64) +CONCRETE_TOCON(Word) +CONCRETE_TOCON(Word8) +CONCRETE_TOCON(Word16) +CONCRETE_TOCON(Word32) +CONCRETE_TOCON(Word64) +CONCRETE_TOCON(B.ByteString) +#endif + +-- Unit +instance ToCon () () where + toCon = Just + +-- Either +deriving via (Default (Either e2 a2)) instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (Either e2 a2) + +-- Maybe +deriving via (Default (Maybe a2)) instance (ToCon a1 a2) => ToCon (Maybe a1) (Maybe a2) + +-- List +deriving via (Default [b]) instance (ToCon a b) => ToCon [a] [b] + +-- (,) +deriving via (Default (a2, b2)) instance (ToCon a1 a2, ToCon b1 b2) => ToCon (a1, b1) (a2, b2) + +-- (,,) +deriving via (Default (a2, b2, c2)) instance (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2) => ToCon (a1, b1, c1) (a2, b2, c2) + +-- (,,,) +deriving via + (Default (a2, b2, c2, d2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2) => ToCon (a1, b1, c1, d1) (a2, b2, c2, d2) + +-- (,,,,) +deriving via + (Default (a2, b2, c2, d2, e2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2) => + ToCon (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) + +-- (,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2) => + ToCon (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) + +-- (,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2) => + ToCon (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) + +-- (,,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2, h2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2, ToCon h1 h2) => + ToCon (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) + +-- MaybeT +instance + ToCon (m1 (Maybe a)) (m2 (Maybe b)) => + ToCon (MaybeT m1 a) (MaybeT m2 b) + where + toCon (MaybeT v) = MaybeT <$> toCon v + +-- ExceptT +instance + ToCon (m1 (Either e1 a)) (m2 (Either e2 b)) => + ToCon (ExceptT e1 m1 a) (ExceptT e2 m2 b) + where + toCon (ExceptT v) = ExceptT <$> toCon v + +instance + ToCon (m1 (Either e1 a)) (Either e2 b) => + ToCon (ExceptT e1 m1 a) (Either e2 b) + where + toCon (ExceptT v) = toCon v + +-- Sum +deriving via + (Default (Sum f1 g1 a1)) + instance + (ToCon (f a) (f1 a1), ToCon (g a) (g1 a1)) => ToCon (Sum f g a) (Sum f1 g1 a1) + +-- WriterT +instance + ToCon (m1 (a, s1)) (m2 (b, s2)) => + ToCon (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) + where + toCon (WriterLazy.WriterT v) = WriterLazy.WriterT <$> toCon v + +instance + ToCon (m1 (a, s1)) (m2 (b, s2)) => + ToCon (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) + where + toCon (WriterStrict.WriterT v) = WriterStrict.WriterT <$> toCon v + +-- Identity +instance ToCon a b => ToCon (Identity a) (Identity b) where + toCon (Identity a) = Identity <$> toCon a + +instance ToCon (Identity v) v where + toCon = Just . runIdentity + +instance ToCon v (Identity v) where + toCon = Just . Identity + +-- IdentityT +instance ToCon (m a) (m1 b) => ToCon (IdentityT m a) (IdentityT m1 b) where + toCon (IdentityT a) = IdentityT <$> toCon a diff --git a/src/Grisette/Core/Data/Class/ToSym.hs b/src/Grisette/Core/Data/Class/ToSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Class/ToSym.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Core.Data.Class.ToSym +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Class.ToSym + ( -- * Converting to symbolic values + ToSym (..), + ) +where + +import Control.Monad.Identity +import Control.Monad.Reader +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum +import Data.Int +import Data.Word +import Generics.Deriving + +-- $setup +-- >>> import Grisette.IR.SymPrim + +-- | Convert a concrete value to symbolic value. +class ToSym a b where + -- | Convert a concrete value to symbolic value. + -- + -- >>> toSym False :: SymBool + -- false + -- + -- >>> toSym [False, True] :: [SymBool] + -- [false,true] + toSym :: a -> b + +instance (Generic a, Generic b, ToSym' (Rep a) (Rep b)) => ToSym a (Default b) where + toSym = Default . to . toSym' . from + +class ToSym' a b where + toSym' :: a c -> b c + +instance ToSym' U1 U1 where + toSym' = id + +instance (ToSym a b) => ToSym' (K1 i a) (K1 i b) where + toSym' (K1 a) = K1 $ toSym a + +instance (ToSym' a b) => ToSym' (M1 i c1 a) (M1 i c2 b) where + toSym' (M1 a) = M1 $ toSym' a + +instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :+: b1) (a2 :+: b2) where + toSym' (L1 a) = L1 $ toSym' a + toSym' (R1 b) = R1 $ toSym' b + +instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :*: b1) (a2 :*: b2) where + toSym' (a :*: b) = toSym' a :*: toSym' b + +#define CONCRETE_TOSYM(type) \ +instance ToSym type type where \ + toSym = id + +#if 1 +CONCRETE_TOSYM(Bool) +CONCRETE_TOSYM(Integer) +CONCRETE_TOSYM(Char) +CONCRETE_TOSYM(Int) +CONCRETE_TOSYM(Int8) +CONCRETE_TOSYM(Int16) +CONCRETE_TOSYM(Int32) +CONCRETE_TOSYM(Int64) +CONCRETE_TOSYM(Word) +CONCRETE_TOSYM(Word8) +CONCRETE_TOSYM(Word16) +CONCRETE_TOSYM(Word32) +CONCRETE_TOSYM(Word64) +CONCRETE_TOSYM(B.ByteString) +#endif + +-- Unit +instance ToSym () () where + toSym = id + +-- Either +deriving via (Default (Either e2 a2)) instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (Either e2 a2) + +-- Maybe +deriving via (Default (Maybe b)) instance ToSym a b => ToSym (Maybe a) (Maybe b) + +-- List +deriving via (Default [b]) instance (ToSym a b) => ToSym [a] [b] + +-- (,) +deriving via (Default (b1, b2)) instance (ToSym a1 b1, ToSym a2 b2) => ToSym (a1, a2) (b1, b2) + +-- (,,) +deriving via (Default (b1, b2, b3)) instance (ToSym a1 b1, ToSym a2 b2, ToSym a3 b3) => ToSym (a1, a2, a3) (b1, b2, b3) + +-- (,,,) +deriving via + (Default (a2, b2, c2, d2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2) => ToSym (a1, b1, c1, d1) (a2, b2, c2, d2) + +-- (,,,,) +deriving via + (Default (a2, b2, c2, d2, e2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2) => + ToSym (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) + +-- (,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2) => + ToSym (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) + +-- (,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2) => + ToSym (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) + +-- (,,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2, h2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2, ToSym h1 h2) => + ToSym (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) + +-- function +instance (ToSym a b) => ToSym (v -> a) (v -> b) where + toSym f = toSym . f + +-- MaybeT +instance + (ToSym (m1 (Maybe a)) (m2 (Maybe b))) => + ToSym (MaybeT m1 a) (MaybeT m2 b) + where + toSym (MaybeT v) = MaybeT $ toSym v + +-- ExceptT +instance + (ToSym (m1 (Either e1 a)) (m2 (Either e2 b))) => + ToSym (ExceptT e1 m1 a) (ExceptT e2 m2 b) + where + toSym (ExceptT v) = ExceptT $ toSym v + +-- StateT +instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateLazy.StateT s1 m1 a1) (StateLazy.StateT s2 m2 a2) where + toSym (StateLazy.StateT f1) = StateLazy.StateT $ toSym f1 + +instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateStrict.StateT s1 m1 a1) (StateStrict.StateT s2 m2 a2) where + toSym (StateStrict.StateT f1) = StateStrict.StateT $ toSym f1 + +-- WriterT +instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterLazy.WriterT s1 m1 a1) (WriterLazy.WriterT s2 m2 a2) where + toSym (WriterLazy.WriterT f1) = WriterLazy.WriterT $ toSym f1 + +instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterStrict.WriterT s1 m1 a1) (WriterStrict.WriterT s2 m2 a2) where + toSym (WriterStrict.WriterT f1) = WriterStrict.WriterT $ toSym f1 + +-- ReaderT +instance (ToSym (s1 -> m1 a1) (s2 -> m2 a2)) => ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) where + toSym (ReaderT f1) = ReaderT $ toSym f1 + +-- Sum +deriving via + (Default (Sum f1 g1 a1)) + instance + (ToSym (f a) (f1 a1), ToSym (g a) (g1 a1)) => ToSym (Sum f g a) (Sum f1 g1 a1) + +-- Identity +instance ToSym a b => ToSym (Identity a) (Identity b) where + toSym (Identity a) = Identity $ toSym a + +-- IdentityT +instance ToSym (m a) (m1 b) => ToSym (IdentityT m a) (IdentityT m1 b) where + toSym (IdentityT v) = IdentityT $ toSym v diff --git a/src/Grisette/Core/Data/FileLocation.hs b/src/Grisette/Core/Data/FileLocation.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/FileLocation.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.Data.FileLocation +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.FileLocation + ( -- * Symbolic constant generation with location + FileLocation (..), + nameWithLoc, + slocsym, + ilocsym, + ) +where + +import Control.DeepSeq +import Data.Hashable +import Debug.Trace.LocationTH (__LOCATION__) +import GHC.Generics +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.Solvable +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Compat + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XTemplateHaskell + +-- File location type. +data FileLocation = FileLocation {locPath :: String, locLineno :: Int, locSpan :: (Int, Int)} + deriving (Eq, Ord, Generic, Lift, NFData, Hashable) + +instance Show FileLocation where + show (FileLocation p l (s1, s2)) = p ++ ":" ++ show l ++ ":" ++ show s1 ++ "-" ++ show s2 + +parseFileLocation :: String -> FileLocation +parseFileLocation str = + let r = reverse str + (s2, r1) = break (== '-') r + (s1, r2) = break (== ':') $ tail r1 + (l, p) = break (== ':') $ tail r2 + in FileLocation (reverse $ tail p) (read $ reverse l) (read $ reverse s1, read $ reverse s2) + +-- | Identifier with the current location as extra information. +-- +-- >>> $$(nameWithLoc "a") -- a sample result could be "a::18:4-18" +-- a::... +-- +-- The uniqueness is ensured for the call to 'nameWithLoc' at different location. +nameWithLoc :: String -> SpliceQ FreshIdent +nameWithLoc s = [||nameWithInfo s (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||] + +-- | Generate simply-named symbolic variables. The file location will be +-- attached to the identifier. +-- +-- >>> $$(slocsym "a") :: SymBool +-- a::... +-- +-- Calling 'slocsymb' with the same name at different location will always +-- generate different symbolic constants. Calling 'slocsymb' at the same +-- location for multiple times will generate the same symbolic constants. +-- +-- >>> ($$(slocsym "a") :: SymBool) == $$(slocsym "a") +-- False +-- >>> let f _ = $$(slocsym "a") :: SymBool +-- >>> f () == f () +-- True +slocsym :: (Solvable c s) => String -> SpliceQ s +slocsym nm = [||sinfosym nm (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||] + +-- | Generate indexed symbolic variables. The file location will be attached to identifier. +-- +-- >>> $$(ilocsym "a" 1) :: SymBool +-- a@1::... +-- +-- Calling 'ilocsymb' with the same name and index at different location will +-- always generate different symbolic constants. Calling 'slocsymb' at the same +-- location for multiple times will generate the same symbolic constants. +ilocsym :: (Solvable c s) => String -> Int -> SpliceQ s +ilocsym nm idx = [||iinfosym nm idx (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||] diff --git a/src/Grisette/Core/Data/MemoUtils.hs b/src/Grisette/Core/Data/MemoUtils.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/MemoUtils.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Core.Data.MemoUtils +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.MemoUtils + ( -- * Hashtable-based memoization + htmemo, + htmemo2, + htmemo3, + htmup, + htmemoFix, + ) +where + +import Data.Function (fix) +import Data.HashTable.IO as H +import Data.Hashable +import System.IO.Unsafe + +type HashTable k v = H.BasicHashTable k v + +-- | Function memoizer with mutable hash table. +htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a +htmemo f = unsafePerformIO $ do + cache <- H.new :: IO (HashTable k v) + return $ \x -> unsafePerformIO $ do + tryV <- H.lookup cache x + case tryV of + Nothing -> do + -- traceM "New value" + let v = f x + H.insert cache x v + return v + Just v -> return v + +-- | Lift a memoizer to work with one more argument. +htmup :: (Eq k, Hashable k) => (b -> c) -> (k -> b) -> (k -> c) +htmup mem f = htmemo (mem . f) + +-- | Function memoizer with mutable hash table. Works on binary functions. +htmemo2 :: (Eq k1, Hashable k1, Eq k2, Hashable k2) => (k1 -> k2 -> a) -> (k1 -> k2 -> a) +htmemo2 = htmup htmemo + +-- | Function memoizer with mutable hash table. Works on ternary functions. +htmemo3 :: + (Eq k1, Hashable k1, Eq k2, Hashable k2, Eq k3, Hashable k3) => + (k1 -> k2 -> k3 -> a) -> + (k1 -> k2 -> k3 -> a) +htmemo3 = htmup htmemo2 + +-- | Memoizing recursion. Use like 'fix'. +htmemoFix :: (Eq k, Hashable k) => ((k -> a) -> (k -> a)) -> k -> a +htmemoFix h = fix (htmemo . h) diff --git a/src/Grisette/Core/Data/Union.hs b/src/Grisette/Core/Data/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/Data/Union.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Core.Data.Union +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.Data.Union + ( -- * The union data structure. + + -- | Please consider using 'UnionM' instead. + Union (..), + ifWithLeftMost, + ifWithStrategy, + fullReconstruct, + ) +where + +import Control.DeepSeq +import Data.Functor.Classes +import Data.Hashable +import GHC.Generics +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.SymPrim +import Language.Haskell.TH.Syntax + +-- | The default union implementation. +data Union a + = -- | A single value + Single a + | -- | A if value + If + a + -- ^ Cached leftmost value + !Bool + -- ^ Is merged invariant already maintained? + !SymBool + -- ^ If condition + (Union a) + -- ^ True branch + (Union a) + -- ^ False branch + deriving (Generic, Eq, Lift, Generic1) + +instance Eq1 Union where + liftEq e (Single a) (Single b) = e a b + liftEq e (If l1 i1 c1 t1 f1) (If l2 i2 c2 t2 f2) = + e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 + liftEq _ _ _ = False + +instance (NFData a) => NFData (Union a) where + rnf = rnf1 + +instance NFData1 Union where + liftRnf _a (Single a) = _a a + liftRnf _a (If a bo b l r) = _a a `seq` rnf bo `seq` rnf b `seq` liftRnf _a l `seq` liftRnf _a r + +-- | Build 'If' with leftmost cache correctly maintained. +-- +-- Usually you should never directly try to build a 'If' with its constructor. +ifWithLeftMost :: Bool -> SymBool -> Union a -> Union a -> Union a +ifWithLeftMost _ (Con c) t f + | c = t + | otherwise = f +ifWithLeftMost inv cond t f = If (leftMost t) inv cond t f +{-# INLINE ifWithLeftMost #-} + +instance UnionPrjOp Union where + singleView (Single a) = Just a + singleView _ = Nothing + {-# INLINE singleView #-} + ifView (If _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) + ifView _ = Nothing + {-# INLINE ifView #-} + leftMost (Single a) = a + leftMost (If a _ _ _ _) = a + {-# INLINE leftMost #-} + +instance (Mergeable a) => Mergeable (Union a) where + rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 Union where + liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms + {-# INLINE liftRootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (Union a) where + mrgIte = mrgIf + +instance SimpleMergeable1 Union where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + +instance UnionLike Union where + mergeWithStrategy = fullReconstruct + {-# INLINE mergeWithStrategy #-} + single = Single + {-# INLINE single #-} + unionIf = ifWithLeftMost False + {-# INLINE unionIf #-} + mrgIfWithStrategy = ifWithStrategy + {-# INLINE mrgIfWithStrategy #-} + mrgSingleWithStrategy _ = Single + {-# INLINE mrgSingleWithStrategy #-} + +instance Show1 Union where + liftShowsPrec sp _ i (Single a) = showsUnaryWith sp "Single" i a + liftShowsPrec sp sl i (If _ _ cond t f) = + showParen (i > 10) $ + showString "If" . showChar ' ' . showsPrec 11 cond . showChar ' ' . sp1 11 t . showChar ' ' . sp1 11 f + where + sp1 = liftShowsPrec sp sl + +instance (Show a) => Show (Union a) where + showsPrec = showsPrec1 + +instance (Hashable a) => Hashable (Union a) where + s `hashWithSalt` (Single a) = s `hashWithSalt` (0 :: Int) `hashWithSalt` a + s `hashWithSalt` (If _ _ c l r) = s `hashWithSalt` (1 :: Int) `hashWithSalt` c `hashWithSalt` l `hashWithSalt` r + +-- | Fully reconstruct a 'Union' to maintain the merged invariant. +fullReconstruct :: MergingStrategy a -> Union a -> Union a +fullReconstruct strategy (If _ False cond t f) = + ifWithStrategyInv strategy cond (fullReconstruct strategy t) (fullReconstruct strategy f) +fullReconstruct _ u = u +{-# INLINE fullReconstruct #-} + +-- | Use a specific strategy to build a 'If' value. +-- +-- The merged invariant will be maintained in the result. +ifWithStrategy :: + MergingStrategy a -> + SymBool -> + Union a -> + Union a -> + Union a +ifWithStrategy strategy cond t@(If _ False _ _ _) f = ifWithStrategy strategy cond (fullReconstruct strategy t) f +ifWithStrategy strategy cond t f@(If _ False _ _ _) = ifWithStrategy strategy cond t (fullReconstruct strategy f) +ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f +{-# INLINE ifWithStrategy #-} + +ifWithStrategyInv :: + MergingStrategy a -> + SymBool -> + Union a -> + Union a -> + Union a +ifWithStrategyInv _ (Con v) t f + | v = t + | otherwise = f +ifWithStrategyInv strategy cond (If _ True condTrue tt _) f + | cond == condTrue = ifWithStrategyInv strategy cond tt f +-- {| nots cond == condTrue || cond == nots condTrue = ifWithStrategyInv strategy cond ft f +ifWithStrategyInv strategy cond t (If _ True condFalse _ ff) + | cond == condFalse = ifWithStrategyInv strategy cond t ff +-- {| nots cond == condTrue || cond == nots condTrue = ifWithStrategyInv strategy cond t tf -- buggy here condTrue +ifWithStrategyInv (SimpleStrategy m) cond (Single l) (Single r) = Single $ m cond l r +ifWithStrategyInv strategy@(SortedStrategy idxFun substrategy) cond ifTrue ifFalse = case (ifTrue, ifFalse) of + (Single _, Single _) -> ssIf cond ifTrue ifFalse + (Single _, If {}) -> sgIf cond ifTrue ifFalse + (If {}, Single _) -> gsIf cond ifTrue ifFalse + _ -> ggIf cond ifTrue ifFalse + where + ssIf cond' ifTrue' ifFalse' + | idxt < idxf = ifWithLeftMost True cond' ifTrue' ifFalse' + | idxt == idxf = ifWithStrategyInv (substrategy idxt) cond' ifTrue' ifFalse' + | otherwise = ifWithLeftMost True (nots cond') ifFalse' ifTrue' + where + idxt = idxFun $ leftMost ifTrue' + idxf = idxFun $ leftMost ifFalse' + {-# INLINE ssIf #-} + sgIf cond' ifTrue' ifFalse'@(If _ True condf ft ff) + | idxft == idxff = ssIf cond' ifTrue' ifFalse' + | idxt < idxft = ifWithLeftMost True cond' ifTrue' ifFalse' + | idxt == idxft = ifWithLeftMost True (cond' ||~ condf) (ifWithStrategyInv (substrategy idxt) cond' ifTrue' ft) ff + | otherwise = ifWithLeftMost True (nots cond' &&~ condf) ft (ifWithStrategyInv strategy cond' ifTrue' ff) + where + idxft = idxFun $ leftMost ft + idxff = idxFun $ leftMost ff + idxt = idxFun $ leftMost ifTrue' + sgIf _ _ _ = undefined + {-# INLINE sgIf #-} + gsIf cond' ifTrue'@(If _ True condt tt tf) ifFalse' + | idxtt == idxtf = ssIf cond' ifTrue' ifFalse' + | idxtt < idxf = ifWithLeftMost True (cond' &&~ condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' + | idxtt == idxf = ifWithLeftMost True (nots cond' ||~ condt) (ifWithStrategyInv (substrategy idxf) cond' tt ifFalse') tf + | otherwise = ifWithLeftMost True (nots cond') ifFalse' ifTrue' + where + idxtt = idxFun $ leftMost tt + idxtf = idxFun $ leftMost tf + idxf = idxFun $ leftMost ifFalse' + gsIf _ _ _ = undefined + {-# INLINE gsIf #-} + ggIf cond' ifTrue'@(If _ True condt tt tf) ifFalse'@(If _ True condf ft ff) + | idxtt == idxtf = sgIf cond' ifTrue' ifFalse' + | idxft == idxff = gsIf cond' ifTrue' ifFalse' + | idxtt < idxft = ifWithLeftMost True (cond' &&~ condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' + | idxtt == idxft = + let newCond = ites cond' condt condf + newIfTrue = ifWithStrategyInv (substrategy idxtt) cond' tt ft + newIfFalse = ifWithStrategyInv strategy cond' tf ff + in ifWithLeftMost True newCond newIfTrue newIfFalse + | otherwise = ifWithLeftMost True (nots cond' &&~ condf) ft $ ifWithStrategyInv strategy cond' ifTrue' ff + where + idxtt = idxFun $ leftMost tt + idxtf = idxFun $ leftMost tf + idxft = idxFun $ leftMost ft + idxff = idxFun $ leftMost ff + ggIf _ _ _ = undefined + {-# INLINE ggIf #-} +ifWithStrategyInv NoStrategy cond ifTrue ifFalse = ifWithLeftMost True cond ifTrue ifFalse +ifWithStrategyInv _ _ _ _ = error "Invariant violated" +{-# INLINE ifWithStrategyInv #-} diff --git a/src/Grisette/Core/TH.hs b/src/Grisette/Core/TH.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/TH.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Core.TH +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Core.TH + ( -- * Template Haskell procedures for building constructor wrappers + makeUnionWrapper, + makeUnionWrapper', + ) +where + +import Control.Monad +import Grisette.Core.THCompat +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- | Generate constructor wrappers that wraps the result in a union-like monad with provided names. +-- +-- > $(makeUnionWrapper' ["mrgTuple2"] ''(,)) +-- +-- generates +-- +-- > mrgTuple2 :: (SymBoolOp bool, Monad u, Mergeable bool t1, Mergeable bool t2, MonadUnion bool u) => t1 -> t2 -> u (t1, t2) +-- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2) +makeUnionWrapper' :: + -- | Names for generated wrappers + [String] -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +makeUnionWrapper' names typName = do + constructors <- getConstructors typName + when (length names /= length constructors) $ + fail "Number of names does not match the number of constructors" + ds <- zipWithM mkSingleWrapper names constructors + return $ join ds + +occName :: Name -> String +occName (Name (OccName name) _) = name + +getConstructorName :: Con -> Q String +getConstructorName (NormalC name _) = return $ occName name +getConstructorName (RecC name _) = return $ occName name +getConstructorName InfixC {} = + fail "You should use makeUnionWrapper' to manually provide the name for infix constructors" +getConstructorName (ForallC _ _ c) = getConstructorName c +getConstructorName (GadtC [name] _ _) = return $ occName name +getConstructorName (RecGadtC [name] _ _) = return $ occName name +getConstructorName c = fail $ "Unsupported constructor at this time: " ++ pprint c + +getConstructors :: Name -> Q [Con] +getConstructors typName = do + d <- reify typName + case d of + TyConI (DataD _ _ _ _ constructors _) -> return constructors + TyConI (NewtypeD _ _ _ _ constructor _) -> return [constructor] + _ -> fail $ "Unsupported declaration: " ++ pprint d + +-- | Generate constructor wrappers that wraps the result in a union-like monad. +-- +-- > $(makeUnionWrapper "mrg" ''Maybe) +-- +-- generates +-- +-- > mrgNothing :: (SymBoolOp bool, Monad u, Mergeable bool t, MonadUnion bool u) => u (Maybe t) +-- > mrgNothing = mrgSingle Nothing +-- > mrgJust :: (SymBoolOp bool, Monad u, Mergeable bool t, MonadUnion bool u) => t -> u (Maybe t) +-- > mrgJust = \x -> mrgSingle (Just x) +makeUnionWrapper :: + -- | Prefix for generated wrappers + String -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +makeUnionWrapper prefix typName = do + constructors <- getConstructors typName + constructorNames <- mapM getConstructorName constructors + makeUnionWrapper' ((prefix ++) <$> constructorNames) typName + +augmentNormalCExpr :: Int -> Exp -> Q Exp +augmentNormalCExpr n f = do + xs <- replicateM n (newName "x") + let args = map VarP xs + mrgSingleFun <- [|mrgSingle|] + return $ + LamE + args + ( AppE mrgSingleFun $ + foldl AppE f (map VarE xs) + ) + +augmentNormalCType :: Type -> Q Type +augmentNormalCType (ForallT tybinders ctx ty1) = do + ((bndrs, preds), augmentedTyp) <- augmentFinalType ty1 + return $ ForallT (bndrs ++ tybinders) (preds ++ ctx) augmentedTyp +augmentNormalCType t = do + ((bndrs, preds), augmentedTyp) <- augmentFinalType t + return $ ForallT bndrs preds augmentedTyp + +mkSingleWrapper :: String -> Con -> Q [Dec] +mkSingleWrapper name (NormalC oriName b) = do + DataConI _ constructorTyp _ <- reify oriName + augmentedTyp <- augmentNormalCType constructorTyp + let retName = mkName name + expr <- augmentNormalCExpr (length b) (ConE oriName) + return + [ SigD retName augmentedTyp, + FunD retName [Clause [] (NormalB expr) []] + ] +mkSingleWrapper name (RecC oriName b) = do + DataConI _ constructorTyp _ <- reify oriName + augmentedTyp <- augmentNormalCType constructorTyp + let retName = mkName name + expr <- augmentNormalCExpr (length b) (ConE oriName) + return + [ SigD retName augmentedTyp, + FunD retName [Clause [] (NormalB expr) []] + ] +mkSingleWrapper _ v = fail $ "Unsupported constructor" ++ pprint v diff --git a/src/Grisette/Core/THCompat.hs b/src/Grisette/Core/THCompat.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Core/THCompat.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{- ORMOLU_DISABLE -} + +-- | +-- Module : Grisette.Core.THCompat +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only + +module Grisette.Core.THCompat (augmentFinalType) where + +import Data.Bifunctor +import Language.Haskell.TH.Syntax +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Control.Monad.UnionM +import Grisette.IR.SymPrim.Data.SymPrim + +#if MIN_VERSION_template_haskell(2,17,0) +augmentFinalType :: Type -> Q (([TyVarBndr Specificity], [Pred]), Type) +#elif MIN_VERSION_template_haskell(2,16,0) +augmentFinalType :: Type -> Q (([TyVarBndr], [Pred]), Type) +#endif +augmentFinalType (AppT a@(AppT ArrowT _) t) = do + tl <- augmentFinalType t + return $ second (AppT a) tl +#if MIN_VERSION_template_haskell(2,17,0) +augmentFinalType (AppT (AppT (AppT MulArrowT _) var) t) = do + tl <- augmentFinalType t + return $ second (AppT (AppT ArrowT var)) tl +#endif +augmentFinalType t = do + unionType <- [t|UnionM|] + mergeable <- [t|Mergeable|] +#if MIN_VERSION_template_haskell(2,17,0) + return + ( ( [ ], + [ AppT mergeable t + ] + ), + AppT unionType t + ) +#elif MIN_VERSION_template_haskell(2,16,0) + return + ( ( [ ], + [ AppT mergeable t + ] + ), + AppT unionType t + ) +#endif diff --git a/src/Grisette/IR/SymPrim.hs b/src/Grisette/IR/SymPrim.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | +-- Module : Grisette.IR.SymPrim +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim + ( -- * Symbolic type implementation + + -- ** Extended types + IntN, + WordN, + type (=->) (..), + type (-->), + (-->), + + -- ** Symbolic types + SupportedPrim, + Sym, + TypedSymbol (..), + symSize, + symsSize, + + -- ** Symbolic type synonyms + SymBool, + SymInteger, + SymIntN, + SymWordN, + type (=~>), + type (-~>), + + -- ** Symbolic constant sets and models + SymbolSet (..), + Model (..), + ModelValuePair (..), + ) +where + +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.Model +import Grisette.IR.SymPrim.Data.SymPrim +import Grisette.IR.SymPrim.Data.TabularFun diff --git a/src/Grisette/IR/SymPrim/Data/BV.hs b/src/Grisette/IR/SymPrim/Data/BV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/BV.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.BV +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.BV (IntN (..), WordN (..)) where + +import Control.DeepSeq +import Control.Exception +import Data.Bits +import Data.Hashable +import Data.Proxy +import GHC.Enum +import GHC.Generics +import GHC.Real +import GHC.TypeNats +import Grisette.Core.Data.Class.BitVector +import Language.Haskell.TH.Syntax +import Numeric + +-- | +-- Symbolic unsigned bit vectors. +newtype WordN (n :: Nat) = WordN {unWordN :: Integer} + deriving (Eq, Ord, Generic, Lift, Hashable, NFData) + +instance (KnownNat n, 1 <= n) => Show (WordN n) where + show (WordN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep + where + bitwidth = natVal (Proxy :: Proxy n) + hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0' + hexRep = showHex w "" + binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' + binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" + +-- | +-- Symbolic signed bit vectors. +newtype IntN (n :: Nat) = IntN {unIntN :: Integer} + deriving (Eq, Generic, Lift, Hashable, NFData) + +instance (KnownNat n, 1 <= n) => Show (IntN n) where + show (IntN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep + where + bitwidth = natVal (Proxy :: Proxy n) + hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0' + hexRep = showHex w "" + binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' + binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" + +instance (KnownNat n, 1 <= n) => Bits (WordN n) where + WordN a .&. WordN b = WordN (a .&. b) + WordN a .|. WordN b = WordN (a .|. b) + WordN a `xor` WordN b = WordN (a `xor` b) + complement a = maxBound `xor` a + + -- shift use default implementation + -- rotate use default implementation + zeroBits = WordN 0 + bit i + | i < 0 || i >= fromIntegral (natVal (Proxy :: Proxy n)) = zeroBits + | otherwise = WordN (bit i) + + -- setBit use default implementation + clearBit (WordN a) i = WordN (clearBit a i) + + -- complementBit use default implementation + testBit (WordN a) = testBit a + bitSizeMaybe _ = Just $ fromIntegral (natVal (Proxy :: Proxy n)) + bitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) + isSigned _ = False + shiftL (WordN a) i = WordN (a `shiftL` i) .&. maxBound + + -- unsafeShiftL use default implementation + shiftR (WordN a) i = WordN (a `shiftR` i) + + -- unsafeShiftR use default implementation + rotateL a 0 = a + rotateL (WordN a) k + | k >= n = rotateL (WordN a) (k `mod` n) + | otherwise = WordN $ l + h + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + s = n - k + l = a `shiftR` s + h = (a - (l `shiftL` s)) `shiftL` k + rotateR a 0 = a + rotateR (WordN a) k + | k >= n = rotateR (WordN a) (k `mod` n) + | otherwise = WordN $ l + h + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + s = n - k + l = a `shiftR` k + h = (a - (l `shiftL` k)) `shiftL` s + popCount (WordN n) = popCount n + +instance (KnownNat n, 1 <= n) => FiniteBits (WordN n) where + finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) + +instance (KnownNat n, 1 <= n) => Bounded (WordN n) where + maxBound = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) - 1) + minBound = WordN 0 + +instance (KnownNat n, 1 <= n) => Enum (WordN n) where + succ x + | x /= maxBound = x + 1 + | otherwise = succError $ "WordN " ++ show (natVal (Proxy :: Proxy n)) + pred x + | x /= minBound = x - 1 + | otherwise = predError $ "WordN " ++ show (natVal (Proxy :: Proxy n)) + toEnum i + | i >= 0 && toInteger i <= toInteger (maxBound :: WordN n) = WordN (toInteger i) + | otherwise = toEnumError ("WordN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n) + fromEnum (WordN n) = fromEnum n + enumFrom = boundedEnumFrom + {-# INLINE enumFrom #-} + enumFromThen = boundedEnumFromThen + {-# INLINE enumFromThen #-} + +instance (KnownNat n, 1 <= n) => Real (WordN n) where + toRational (WordN n) = n % 1 + +instance (KnownNat n, 1 <= n) => Integral (WordN n) where + quot (WordN x) (WordN y) = WordN (x `quot` y) + rem (WordN x) (WordN y) = WordN (x `rem` y) + quotRem (WordN x) (WordN y) = case quotRem x y of + (q, r) -> (WordN q, WordN r) + div = quot + mod = rem + divMod = quotRem + toInteger (WordN n) = n + +instance (KnownNat n, 1 <= n) => Num (WordN n) where + WordN x + WordN y = WordN (x + y) .&. maxBound + WordN x * WordN y = WordN (x * y) .&. maxBound + WordN x - WordN y + | x >= y = WordN (x - y) + | otherwise = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y) + negate (WordN 0) = WordN 0 + negate a = complement a + WordN 1 + abs x = x + signum (WordN 0) = 0 + signum _ = 1 + fromInteger !x + | x == 0 = WordN 0 + | x > 0 = WordN (x .&. unWordN (maxBound :: WordN n)) + | otherwise = -fromInteger (-x) + +minusOneIntN :: forall proxy n. KnownNat n => proxy n -> IntN n +minusOneIntN _ = IntN (1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n)) - 1) + +instance (KnownNat n, 1 <= n) => Bits (IntN n) where + IntN a .&. IntN b = IntN (a .&. b) + IntN a .|. IntN b = IntN (a .|. b) + IntN a `xor` IntN b = IntN (a `xor` b) + complement a = minusOneIntN (Proxy :: Proxy n) `xor` a + + -- shift use default implementation + -- rotate use default implementation + zeroBits = IntN 0 + bit i = IntN (unWordN (bit i :: WordN n)) + + -- setBit use default implementation + clearBit (IntN a) i = IntN (clearBit a i) + + -- complementBit use default implementation + testBit (IntN a) = testBit a + bitSizeMaybe _ = Just $ fromIntegral (natVal (Proxy :: Proxy n)) + bitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) + isSigned _ = True + + shiftL (IntN a) i = IntN (unWordN $ (WordN a :: WordN n) `shiftL` i) + + -- unsafeShiftL use default implementation + shiftR i 0 = i + shiftR (IntN i) k + | k >= n = if b then IntN (maxi - 1) else IntN 0 + | otherwise = if b then IntN (maxi - noi + (i `shiftR` k)) else IntN (i `shiftR` k) + where + b = testBit i (n - 1) + n = fromIntegral $ natVal (Proxy :: Proxy n) + maxi = (1 :: Integer) `shiftL` n + noi = (1 :: Integer) `shiftL` (n - k) + + -- unsafeShiftR use default implementation + rotateL (IntN i) k = IntN $ unWordN $ rotateL (WordN i :: WordN n) k + rotateR (IntN i) k = IntN $ unWordN $ rotateR (WordN i :: WordN n) k + popCount (IntN i) = popCount i + +instance (KnownNat n, 1 <= n) => FiniteBits (IntN n) where + finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) + +instance (KnownNat n, 1 <= n) => Bounded (IntN n) where + maxBound = IntN (1 `shiftL` (fromIntegral (natVal (Proxy :: Proxy n)) - 1) - 1) + minBound = maxBound + 1 + +instance (KnownNat n, 1 <= n) => Enum (IntN n) where + succ x + | x /= maxBound = x + 1 + | otherwise = succError $ "IntN " ++ show (natVal (Proxy :: Proxy n)) + pred x + | x /= minBound = x - 1 + | otherwise = predError $ "IntN " ++ show (natVal (Proxy :: Proxy n)) + toEnum i + | i >= fromIntegral (minBound :: IntN n) && i <= fromIntegral (maxBound :: IntN n) = fromIntegral i + | otherwise = toEnumError ("IntN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n) + fromEnum = fromEnum . toInteger + enumFrom = boundedEnumFrom + {-# INLINE enumFrom #-} + enumFromThen = boundedEnumFromThen + {-# INLINE enumFromThen #-} + +instance (KnownNat n, 1 <= n) => Real (IntN n) where + toRational i = toInteger i % 1 + +instance (KnownNat n, 1 <= n) => Integral (IntN n) where + quot x y = + if x == minBound && y == -1 + then throw Overflow + else fromInteger (toInteger x `quot` toInteger y) + rem x y = + if x == minBound && y == -1 + then throw Overflow + else fromInteger (toInteger x `rem` toInteger y) + quotRem x y = + if x == minBound && y == -1 + then throw Overflow + else case quotRem (toInteger x) (toInteger y) of + (q, r) -> (fromInteger q, fromInteger r) + div x y = + if x == minBound && y == -1 + then throw Overflow + else fromInteger (toInteger x `div` toInteger y) + mod x y = + if x == minBound && y == -1 + then throw Overflow + else fromInteger (toInteger x `mod` toInteger y) + divMod x y = + if x == minBound && y == -1 + then throw Overflow + else case divMod (toInteger x) (toInteger y) of + (q, r) -> (fromInteger q, fromInteger r) + toInteger i@(IntN n) = case signum i of + 0 -> 0 + 1 -> n + -1 -> + let x = negate i + in if signum x == -1 then -n else negate (toInteger x) + _ -> undefined + +instance (KnownNat n, 1 <= n) => Num (IntN n) where + IntN x + IntN y = IntN (x + y) .&. minusOneIntN (Proxy :: Proxy n) + IntN x * IntN y = IntN (x * y) .&. minusOneIntN (Proxy :: Proxy n) + IntN x - IntN y + | x >= y = IntN (x - y) + | otherwise = IntN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y) + negate (IntN 0) = IntN 0 + negate a = complement a + IntN 1 + abs x = if testBit x (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then negate x else x + signum (IntN 0) = IntN 0 + signum i = if testBit i (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then -1 else 1 + fromInteger !x = IntN $ if v >= 0 then v else (1 `shiftL` n) + v + where + v = unWordN (fromInteger (x + maxn) :: WordN n) - maxn + n = fromIntegral (natVal (Proxy :: Proxy n)) + maxn = 1 `shiftL` (n - 1) - 1 + +instance (KnownNat n, 1 <= n) => Ord (IntN n) where + IntN a <= IntN b + | as && not bs = True + | not as && bs = False + | otherwise = a <= b + where + n = fromIntegral (natVal (Proxy :: Proxy n)) + as = testBit a (n - 1) + bs = testBit b (n - 1) + +instance + (KnownNat n, 1 <= n, KnownNat m, 1 <= m, KnownNat w, 1 <= w, w ~ (n + m)) => + BVConcat (WordN n) (WordN m) (WordN w) + where + bvconcat (WordN a) (WordN b) = WordN ((a `shiftL` fromIntegral (natVal (Proxy :: Proxy m))) .|. b) + +instance + (KnownNat n, 1 <= n, KnownNat m, 1 <= m, KnownNat w, 1 <= w, w ~ (n + m)) => + BVConcat (IntN n) (IntN m) (IntN w) + where + bvconcat (IntN a) (IntN b) = IntN $ unWordN $ bvconcat (WordN a :: WordN n) (WordN b :: WordN m) + +instance (KnownNat n, 1 <= n, KnownNat r, n <= r) => BVExtend (WordN n) r (WordN r) where + bvzeroExtend _ (WordN v) = WordN v + bvsignExtend pr (WordN v) = if s then WordN (maxi - noi + v) else WordN v + where + r = fromIntegral $ natVal pr + n = fromIntegral $ natVal (Proxy :: Proxy n) + s = testBit v (n - 1) + maxi = (1 :: Integer) `shiftL` r + noi = (1 :: Integer) `shiftL` n + bvextend = bvzeroExtend + +instance (KnownNat n, 1 <= n, KnownNat r, n <= r) => BVExtend (IntN n) r (IntN r) where + bvzeroExtend _ (IntN v) = IntN v + bvsignExtend pr (IntN v) = IntN $ unWordN $ bvsignExtend pr (WordN v :: WordN n) + bvextend = bvsignExtend + +instance (KnownNat n, 1 <= n, KnownNat ix, KnownNat w, 1 <= w, ix + w <= n) => BVSelect (WordN n) ix w (WordN w) where + bvselect pix pw (WordN v) = WordN ((v `shiftR` ix) .&. mask) + where + ix = fromIntegral $ natVal pix + w = fromIntegral $ natVal pw + mask = (1 `shiftL` w) - 1 + +instance (KnownNat n, 1 <= n, KnownNat ix, KnownNat w, 1 <= w, ix + w <= n) => BVSelect (IntN n) ix w (IntN w) where + bvselect pix pw (IntN v) = IntN $ unWordN $ bvselect pix pw (WordN v :: WordN n) diff --git a/src/Grisette/IR/SymPrim/Data/IntBitwidth.hs b/src/Grisette/IR/SymPrim/Data/IntBitwidth.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/IntBitwidth.hs @@ -0,0 +1,15 @@ +-- | +-- Module : Grisette.IR.SymPrim.Data.IntBitwidth +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.IntBitwidth where + +import Data.Bits (FiniteBits (finiteBitSize)) +import Language.Haskell.TH + +intBitwidthQ :: TypeQ +intBitwidthQ = return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int)) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs b/src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.Helpers +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.Helpers + ( pattern UnaryTermPatt, + pattern BinaryTermPatt, + pattern TernaryTermPatt, + pattern UnsafeUnaryTermPatt, + pattern UnsafeBinaryTermPatt, + pattern Unsafe1t21BinaryTermPatt, + pattern Unsafe1u2t32TernaryTermPatt, + ) +where + +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Unsafe.Coerce + +unsafeUnaryTermView :: forall a b tag. (Typeable tag) => Term a -> Maybe (tag, Term b) +unsafeUnaryTermView (UnaryTerm _ (tag :: tagt) t1) = + case cast tag of + Just t -> Just (t, unsafeCoerce t1) + Nothing -> Nothing +-- (,) <$> cast tag <*> castTerm t1 +unsafeUnaryTermView _ = Nothing + +pattern UnsafeUnaryTermPatt :: forall a b tag. (Typeable tag) => tag -> Term b -> Term a +pattern UnsafeUnaryTermPatt tag t <- (unsafeUnaryTermView @a @b @tag -> Just (tag, t)) + +unaryTermView :: forall a b tag. (Typeable tag, Typeable b) => Term a -> Maybe (tag, Term b) +unaryTermView (UnaryTerm _ (tag :: tagt) t1) = + (,) <$> cast tag <*> castTerm t1 +unaryTermView _ = Nothing + +pattern UnaryTermPatt :: forall a b tag. (Typeable tag, Typeable b) => tag -> Term b -> Term a +pattern UnaryTermPatt tag t <- (unaryTermView @a @b @tag -> Just (tag, t)) + +unsafeBinaryTermView :: forall a b c tag. (Typeable tag) => Term a -> Maybe (tag, Term b, Term c) +unsafeBinaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) = + case cast tag of + Just t -> Just (t, unsafeCoerce t1, unsafeCoerce t2) + Nothing -> Nothing +-- (,) <$> cast tag <*> castTerm t1 +unsafeBinaryTermView _ = Nothing + +pattern UnsafeBinaryTermPatt :: forall a b c tag. (Typeable tag) => tag -> Term b -> Term c -> Term a +pattern UnsafeBinaryTermPatt tag t1 t2 <- (unsafeBinaryTermView @a @b @c @tag -> Just (tag, t1, t2)) + +unsafe1t21BinaryTermView :: forall a b tag. (Typeable tag, Typeable b) => Term a -> Maybe (tag, Term b, Term b) +unsafe1t21BinaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) = + case (cast tag, cast t1) of + (Just tg, Just t1') -> Just (tg, t1', unsafeCoerce t2) + _ -> Nothing +-- (,) <$> cast tag <*> castTerm t1 +unsafe1t21BinaryTermView _ = Nothing + +pattern Unsafe1t21BinaryTermPatt :: forall a b tag. (Typeable tag, Typeable b) => tag -> Term b -> Term b -> Term a +pattern Unsafe1t21BinaryTermPatt tag t1 t2 <- (unsafe1t21BinaryTermView @a @b @tag -> Just (tag, t1, t2)) + +binaryTermView :: forall a b c tag. (Typeable tag, Typeable b, Typeable c) => Term a -> Maybe (tag, Term b, Term c) +binaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) = + (,,) <$> cast tag <*> castTerm t1 <*> castTerm t2 +binaryTermView _ = Nothing + +pattern BinaryTermPatt :: forall a b c tag. (Typeable tag, Typeable b, Typeable c) => tag -> Term b -> Term c -> Term a +pattern BinaryTermPatt tag l r <- (binaryTermView @a @b @c @tag -> Just (tag, l, r)) + +unsafe1u2t32TernaryTermView :: + forall a b c tag. + (Typeable tag, Typeable c) => + Term a -> + Maybe (tag, Term b, Term c, Term c) +unsafe1u2t32TernaryTermView (TernaryTerm _ (tag :: tagt) t1 t2 t3) = + case (cast tag, castTerm t2) of + (Just tg, Just t2') -> Just (tg, unsafeCoerce t1, t2', unsafeCoerce t3) + _ -> Nothing +unsafe1u2t32TernaryTermView _ = Nothing + +pattern Unsafe1u2t32TernaryTermPatt :: + forall a b c tag. + (Typeable tag, Typeable c) => + tag -> + Term b -> + Term c -> + Term c -> + Term a +pattern Unsafe1u2t32TernaryTermPatt tag a b c <- + (unsafe1u2t32TernaryTermView @a @b @c @tag -> Just (tag, a, b, c)) + +ternaryTermView :: + forall a b c d tag. + (Typeable tag, Typeable b, Typeable c, Typeable d) => + Term a -> + Maybe (tag, Term b, Term c, Term d) +ternaryTermView (TernaryTerm _ (tag :: tagt) t1 t2 t3) = + (,,,) <$> cast tag <*> castTerm t1 <*> castTerm t2 <*> castTerm t3 +ternaryTermView _ = Nothing + +pattern TernaryTermPatt :: + forall a b c d tag. + (Typeable tag, Typeable b, Typeable c, Typeable d) => + tag -> + Term b -> + Term c -> + Term d -> + Term a +pattern TernaryTermPatt tag a b c <- (ternaryTermView @a @b @c @d @tag -> Just (tag, a, b, c)) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches (typeMemoizedCache) where + +import Control.Once +import Data.Data +import qualified Data.HashMap.Strict as M +import Data.IORef +import Data.Interned +import GHC.Base (Any) +import GHC.IO +import Unsafe.Coerce + +termCacheCell :: IO (IORef (M.HashMap TypeRep Any)) +termCacheCell = unsafeDupablePerformIO $ once $ newIORef M.empty + +typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a +typeMemoizedCache = unsafeDupablePerformIO $ do + c <- termCacheCell + atomicModifyIORef' c $ \m -> + case M.lookup (typeRep (Proxy @a)) m of + Just d -> (m, unsafeCoerce d) + Nothing -> (M.insert (typeRep (Proxy @a)) (unsafeCoerce r1) m, r1) + where + r1 :: Cache a + !r1 = mkCache + {-# NOINLINE r1 #-} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors + ( constructUnary, + constructBinary, + constructTernary, + conTerm, + symTerm, + ssymTerm, + isymTerm, + sinfosymTerm, + iinfosymTerm, + notTerm, + orTerm, + andTerm, + eqvTerm, + iteTerm, + addNumTerm, + uminusNumTerm, + timesNumTerm, + absNumTerm, + signumNumTerm, + ltNumTerm, + leNumTerm, + andBitsTerm, + orBitsTerm, + xorBitsTerm, + complementBitsTerm, + shiftBitsTerm, + rotateBitsTerm, + bvconcatTerm, + bvselectTerm, + bvextendTerm, + bvsignExtendTerm, + bvzeroExtendTerm, + tabularFunApplyTerm, + generalFunApplyTerm, + divIntegerTerm, + modIntegerTerm, + ) +where + +import Control.DeepSeq +import Data.Array +import Data.Bits +import qualified Data.HashMap.Strict as M +import Data.Hashable +import Data.IORef (atomicModifyIORef') +import Data.Interned +import Data.Interned.Internal +import GHC.IO (unsafeDupablePerformIO) +import GHC.TypeNats +import Grisette.Core.Data.Class.BitVector +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.TabularFun +import Language.Haskell.TH.Syntax +import Type.Reflection + +internTerm :: forall t. (SupportedPrim t) => Uninterned (Term t) -> Term t +internTerm !bt = unsafeDupablePerformIO $ atomicModifyIORef' slot go + where + slot = getCache cache ! r + !dt = describe bt + !hdt = hash dt + !wid = cacheWidth dt + r = hdt `mod` wid + go (CacheState i m) = case M.lookup dt m of + Nothing -> let t = identify (wid * i + r) bt in (CacheState (i + 1) (M.insert dt t m), t) + Just t -> (CacheState i m, t) + +constructUnary :: + forall tag arg t. + (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg -> + Term t +constructUnary tag tm = let x = internTerm $ UUnaryTerm tag tm in x +{-# INLINE constructUnary #-} + +constructBinary :: + forall tag arg1 arg2 t. + (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg1 -> + Term arg2 -> + Term t +constructBinary tag tm1 tm2 = internTerm $ UBinaryTerm tag tm1 tm2 +{-# INLINE constructBinary #-} + +constructTernary :: + forall tag arg1 arg2 arg3 t. + (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg1 -> + Term arg2 -> + Term arg3 -> + Term t +constructTernary tag tm1 tm2 tm3 = internTerm $ UTernaryTerm tag tm1 tm2 tm3 +{-# INLINE constructTernary #-} + +conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t +conTerm t = internTerm $ UConTerm t +{-# INLINE conTerm #-} + +symTerm :: forall t. (SupportedPrim t, Typeable t) => TypedSymbol t -> Term t +symTerm t = internTerm $ USymTerm t +{-# INLINE symTerm #-} + +ssymTerm :: (SupportedPrim t, Typeable t) => String -> Term t +ssymTerm = symTerm . SimpleSymbol +{-# INLINE ssymTerm #-} + +isymTerm :: (SupportedPrim t, Typeable t) => String -> Int -> Term t +isymTerm str idx = symTerm $ IndexedSymbol str idx +{-# INLINE isymTerm #-} + +sinfosymTerm :: + (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => + String -> + a -> + Term t +sinfosymTerm s info = symTerm $ WithInfo (SimpleSymbol s) info +{-# INLINE sinfosymTerm #-} + +iinfosymTerm :: + (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => + String -> + Int -> + a -> + Term t +iinfosymTerm str idx info = symTerm $ WithInfo (IndexedSymbol str idx) info +{-# INLINE iinfosymTerm #-} + +notTerm :: Term Bool -> Term Bool +notTerm = internTerm . UNotTerm +{-# INLINE notTerm #-} + +orTerm :: Term Bool -> Term Bool -> Term Bool +orTerm l r = internTerm $ UOrTerm l r +{-# INLINE orTerm #-} + +andTerm :: Term Bool -> Term Bool -> Term Bool +andTerm l r = internTerm $ UAndTerm l r +{-# INLINE andTerm #-} + +eqvTerm :: SupportedPrim a => Term a -> Term a -> Term Bool +eqvTerm l r = internTerm $ UEqvTerm l r +{-# INLINE eqvTerm #-} + +iteTerm :: SupportedPrim a => Term Bool -> Term a -> Term a -> Term a +iteTerm c l r = internTerm $ UITETerm c l r +{-# INLINE iteTerm #-} + +addNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a +addNumTerm l r = internTerm $ UAddNumTerm l r +{-# INLINE addNumTerm #-} + +uminusNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +uminusNumTerm = internTerm . UUMinusNumTerm +{-# INLINE uminusNumTerm #-} + +timesNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a +timesNumTerm l r = internTerm $ UTimesNumTerm l r +{-# INLINE timesNumTerm #-} + +absNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +absNumTerm = internTerm . UAbsNumTerm +{-# INLINE absNumTerm #-} + +signumNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +signumNumTerm = internTerm . USignumNumTerm +{-# INLINE signumNumTerm #-} + +ltNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool +ltNumTerm l r = internTerm $ ULTNumTerm l r +{-# INLINE ltNumTerm #-} + +leNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool +leNumTerm l r = internTerm $ ULENumTerm l r +{-# INLINE leNumTerm #-} + +andBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a +andBitsTerm l r = internTerm $ UAndBitsTerm l r +{-# INLINE andBitsTerm #-} + +orBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a +orBitsTerm l r = internTerm $ UOrBitsTerm l r +{-# INLINE orBitsTerm #-} + +xorBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a +xorBitsTerm l r = internTerm $ UXorBitsTerm l r +{-# INLINE xorBitsTerm #-} + +complementBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a +complementBitsTerm = internTerm . UComplementBitsTerm +{-# INLINE complementBitsTerm #-} + +shiftBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Int -> Term a +shiftBitsTerm t n = internTerm $ UShiftBitsTerm t n +{-# INLINE shiftBitsTerm #-} + +rotateBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Int -> Term a +rotateBitsTerm t n = internTerm $ URotateBitsTerm t n +{-# INLINE rotateBitsTerm #-} + +bvconcatTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + SupportedPrim (bv c), + KnownNat a, + KnownNat b, + KnownNat c, + BVConcat (bv a) (bv b) (bv c) + ) => + Term (bv a) -> + Term (bv b) -> + Term (bv c) +bvconcatTerm l r = internTerm $ UBVConcatTerm l r +{-# INLINE bvconcatTerm #-} + +bvselectTerm :: + forall bv a ix w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat w, + KnownNat ix, + BVSelect (bv a) ix w (bv w) + ) => + proxy ix -> + proxy w -> + Term (bv a) -> + Term (bv w) +bvselectTerm _ _ v = internTerm $ UBVSelectTerm (typeRep @ix) (typeRep @w) v +{-# INLINE bvselectTerm #-} + +bvextendTerm :: + forall bv a n w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat n, + KnownNat w, + BVExtend (bv a) n (bv w) + ) => + Bool -> + proxy n -> + Term (bv a) -> + Term (bv w) +bvextendTerm signed _ v = internTerm $ UBVExtendTerm signed (typeRep @n) v +{-# INLINE bvextendTerm #-} + +bvsignExtendTerm :: + forall bv a n w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat n, + KnownNat w, + BVExtend (bv a) n (bv w) + ) => + proxy n -> + Term (bv a) -> + Term (bv w) +bvsignExtendTerm _ v = internTerm $ UBVExtendTerm True (typeRep @n) v +{-# INLINE bvsignExtendTerm #-} + +bvzeroExtendTerm :: + forall bv a n w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat n, + KnownNat w, + BVExtend (bv a) n (bv w) + ) => + proxy n -> + Term (bv a) -> + Term (bv w) +bvzeroExtendTerm _ v = internTerm $ UBVExtendTerm False (typeRep @n) v +{-# INLINE bvzeroExtendTerm #-} + +tabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b +tabularFunApplyTerm f a = internTerm $ UTabularFunApplyTerm f a +{-# INLINE tabularFunApplyTerm #-} + +generalFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b +generalFunApplyTerm f a = internTerm $ UGeneralFunApplyTerm f a +{-# INLINE generalFunApplyTerm #-} + +divIntegerTerm :: Term Integer -> Term Integer -> Term Integer +divIntegerTerm l r = internTerm $ UDivIntegerTerm l r +{-# INLINE divIntegerTerm #-} + +modIntegerTerm :: Term Integer -> Term Integer -> Term Integer +modIntegerTerm l r = internTerm $ UModIntegerTerm l r +{-# INLINE modIntegerTerm #-} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot @@ -0,0 +1,173 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors + ( constructUnary, + constructBinary, + constructTernary, + conTerm, + symTerm, + ssymTerm, + isymTerm, + sinfosymTerm, + iinfosymTerm, + notTerm, + orTerm, + andTerm, + eqvTerm, + iteTerm, + addNumTerm, + uminusNumTerm, + timesNumTerm, + absNumTerm, + signumNumTerm, + ltNumTerm, + leNumTerm, + andBitsTerm, + orBitsTerm, + xorBitsTerm, + complementBitsTerm, + shiftBitsTerm, + rotateBitsTerm, + bvconcatTerm, + bvselectTerm, + bvextendTerm, + bvsignExtendTerm, + bvzeroExtendTerm, + tabularFunApplyTerm, + generalFunApplyTerm, + divIntegerTerm, + modIntegerTerm, + ) +where + +import Control.DeepSeq +import Data.Bits +import Data.Hashable +import Data.Typeable +import GHC.TypeNats +import Grisette.Core.Data.Class.BitVector +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.TabularFun +import Language.Haskell.TH.Syntax + +constructUnary :: + forall tag arg t. + (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg -> + Term t +constructBinary :: + forall tag arg1 arg2 t. + (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg1 -> + Term arg2 -> + Term t +constructTernary :: + forall tag arg1 arg2 arg3 t. + (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg1 -> + Term arg2 -> + Term arg3 -> + Term t +conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t +symTerm :: (SupportedPrim t, Typeable t) => TypedSymbol t -> Term t +ssymTerm :: (SupportedPrim t, Typeable t) => String -> Term t +isymTerm :: (SupportedPrim t, Typeable t) => String -> Int -> Term t +sinfosymTerm :: + (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => + String -> + a -> + Term t +iinfosymTerm :: + (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => + String -> + Int -> + a -> + Term t +notTerm :: Term Bool -> Term Bool +orTerm :: Term Bool -> Term Bool -> Term Bool +andTerm :: Term Bool -> Term Bool -> Term Bool +eqvTerm :: SupportedPrim a => Term a -> Term a -> Term Bool +iteTerm :: SupportedPrim a => Term Bool -> Term a -> Term a -> Term a +addNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a +uminusNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +timesNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a +absNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +signumNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +ltNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool +leNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool +andBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a +orBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a +xorBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a +complementBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a +shiftBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Int -> Term a +rotateBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Int -> Term a +bvconcatTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + SupportedPrim (bv c), + KnownNat a, + KnownNat b, + KnownNat c, + BVConcat (bv a) (bv b) (bv c) + ) => + Term (bv a) -> + Term (bv b) -> + Term (bv c) +bvselectTerm :: + forall bv a ix w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat w, + KnownNat ix, + BVSelect (bv a) ix w (bv w) + ) => + proxy ix -> + proxy w -> + Term (bv a) -> + Term (bv w) +bvextendTerm :: + forall bv a n w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat n, + KnownNat w, + BVExtend (bv a) n (bv w) + ) => + Bool -> + proxy n -> + Term (bv a) -> + Term (bv w) +bvsignExtendTerm :: + forall bv a n w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat n, + KnownNat w, + BVExtend (bv a) n (bv w) + ) => + proxy n -> + Term (bv a) -> + Term (bv w) +bvzeroExtendTerm :: + forall bv a n w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat n, + KnownNat w, + BVExtend (bv a) n (bv w) + ) => + proxy n -> + Term (bv a) -> + Term (bv w) +tabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b +generalFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b +divIntegerTerm :: Term Integer -> Term Integer -> Term Integer +modIntegerTerm :: Term Integer -> Term Integer -> Term Integer diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm (SomeTerm (..)) where + +import Data.Hashable +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils + +data SomeTerm where + SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm + +instance Eq SomeTerm where + (SomeTerm t1) == (SomeTerm t2) = identityWithTypeRep t1 == identityWithTypeRep t2 + +instance Hashable SomeTerm where + hashWithSalt s (SomeTerm t) = hashWithSalt s $ identityWithTypeRep t + +instance Show SomeTerm where + show (SomeTerm (t :: Term a)) = "<<" ++ show t ++ " :: " ++ show (typeRep (Proxy @a)) ++ ">>" diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs @@ -0,0 +1,886 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + ( SupportedPrim (..), + UnaryOp (..), + BinaryOp (..), + TernaryOp (..), + TypedSymbol (..), + SomeTypedSymbol (..), + showUntyped, + withSymbolSupported, + someTypedSymbol, + Term (..), + UTerm (..), + FunArg (..), + type (-->) (..), + ) +where + +import Control.DeepSeq +import Data.Bits +import Data.Function (on) +import Data.Hashable +import Data.Interned +import Data.Kind +import Data.String +import Data.Typeable (Proxy (..), cast) +import GHC.Generics +import GHC.TypeNats +import Grisette.Core.Data.Class.BitVector +import Grisette.Core.Data.Class.Function +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.Prim.ModelValue +import Grisette.IR.SymPrim.Data.Prim.Utils +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.TabularFun +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Compat +import Type.Reflection + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | Indicates that a type is supported and can be represented as a symbolic +-- term. +class (Lift t, Typeable t, Hashable t, Eq t, Show t, NFData t) => SupportedPrim t where + type PrimConstraint t :: Constraint + type PrimConstraint t = () + default withPrim :: PrimConstraint t => proxy t -> (PrimConstraint t => a) -> a + withPrim :: proxy t -> (PrimConstraint t => a) -> a + withPrim _ i = i + termCache :: Cache (Term t) + termCache = typeMemoizedCache + pformatCon :: t -> String + default pformatCon :: (Show t) => t -> String + pformatCon = show + pformatSym :: TypedSymbol t -> String + pformatSym = showUntyped + defaultValue :: t + defaultValueDynamic :: proxy t -> ModelValue + defaultValueDynamic _ = toModelValue (defaultValue @t) + +class + (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) => + UnaryOp tag arg t + | tag arg -> t + where + partialEvalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t + pformatUnary :: tag -> Term arg -> String + +class + ( SupportedPrim arg1, + SupportedPrim arg2, + SupportedPrim t, + Lift tag, + NFData tag, + Show tag, + Typeable tag, + Eq tag, + Hashable tag + ) => + BinaryOp tag arg1 arg2 t + | tag arg1 arg2 -> t + where + partialEvalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t + pformatBinary :: tag -> Term arg1 -> Term arg2 -> String + +class + ( SupportedPrim arg1, + SupportedPrim arg2, + SupportedPrim arg3, + SupportedPrim t, + Lift tag, + NFData tag, + Show tag, + Typeable tag, + Eq tag, + Hashable tag + ) => + TernaryOp tag arg1 arg2 arg3 t + | tag arg1 arg2 arg3 -> t + where + partialEvalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t + pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String + +-- | A typed symbol is a symbol that is associated with a type. Note that the +-- same symbol bodies with different types are considered different symbols +-- and can coexist in a term. +-- +-- Simple symbols can be created with the 'OverloadedStrings' extension: +-- +-- >>> :set -XOverloadedStrings +-- >>> "a" :: TypedSymbol Bool +-- a :: Bool +data TypedSymbol t where + SimpleSymbol :: SupportedPrim t => String -> TypedSymbol t + IndexedSymbol :: SupportedPrim t => String -> Int -> TypedSymbol t + WithInfo :: + forall t a. + ( SupportedPrim t, + Typeable a, + Ord a, + Lift a, + NFData a, + Show a, + Hashable a + ) => + TypedSymbol t -> + a -> + TypedSymbol t + +-- deriving (Eq, Ord, Generic, Lift, NFData) + +instance Eq (TypedSymbol t) where + SimpleSymbol x == SimpleSymbol y = x == y + IndexedSymbol x i == IndexedSymbol y j = i == j && x == y + WithInfo s1 (i1 :: a) == WithInfo s2 (i2 :: b) = case eqTypeRep (typeRep @a) (typeRep @b) of + Just HRefl -> i1 == i2 && s1 == s2 + _ -> False + _ == _ = False + +instance Ord (TypedSymbol t) where + SimpleSymbol x <= SimpleSymbol y = x <= y + IndexedSymbol x i <= IndexedSymbol y j = i < j || (i == j && x <= y) + WithInfo s1 (i1 :: a) <= WithInfo s2 (i2 :: b) = case eqTypeRep (typeRep @a) (typeRep @b) of + Just HRefl -> s1 < s2 || (s1 == s2 && i1 <= i2) + _ -> False + _ <= _ = False + +instance Lift (TypedSymbol t) where + liftTyped (SimpleSymbol x) = [||SimpleSymbol x||] + liftTyped (IndexedSymbol x i) = [||IndexedSymbol x i||] + liftTyped (WithInfo s1 i1) = [||WithInfo s1 i1||] + +instance Show (TypedSymbol t) where + show (SimpleSymbol str) = str ++ " :: " ++ show (typeRep @t) + show (IndexedSymbol str i) = str ++ "@" ++ show i ++ " :: " ++ show (typeRep @t) + show (WithInfo s info) = showUntyped s ++ ":" ++ show info ++ " :: " ++ show (typeRep @t) + +showUntyped :: TypedSymbol t -> String +showUntyped (SimpleSymbol str) = str +showUntyped (IndexedSymbol str i) = str ++ "@" ++ show i +showUntyped (WithInfo s info) = showUntyped s ++ ":" ++ show info + +instance Hashable (TypedSymbol t) where + s `hashWithSalt` SimpleSymbol x = s `hashWithSalt` x + s `hashWithSalt` IndexedSymbol x i = s `hashWithSalt` x `hashWithSalt` i + s `hashWithSalt` WithInfo sym info = s `hashWithSalt` sym `hashWithSalt` info + +instance NFData (TypedSymbol t) where + rnf (SimpleSymbol str) = rnf str + rnf (IndexedSymbol str i) = rnf str `seq` rnf i + rnf (WithInfo s info) = rnf s `seq` rnf info + +instance SupportedPrim t => IsString (TypedSymbol t) where + fromString = SimpleSymbol + +withSymbolSupported :: TypedSymbol t -> (SupportedPrim t => a) -> a +withSymbolSupported (SimpleSymbol _) a = a +withSymbolSupported (IndexedSymbol _ _) a = a +withSymbolSupported (WithInfo _ _) a = a + +{- +data TypedSymbol t where + TypedSymbol :: (SupportedPrim t) => Symbol -> TypedSymbol t + +typedSymbol :: forall proxy t. (SupportedPrim t) => proxy t -> Symbol -> TypedSymbol t +typedSymbol _ = TypedSymbol + +instance NFData (TypedSymbol t) where + rnf (TypedSymbol s) = rnf s + +instance Eq (TypedSymbol t) where + (TypedSymbol s1) == (TypedSymbol s2) = s1 == s2 + +instance Ord (TypedSymbol t) where + (TypedSymbol s1) <= (TypedSymbol s2) = s1 <= s2 + +instance Hashable (TypedSymbol t) where + hashWithSalt s (TypedSymbol s1) = s `hashWithSalt` s1 + +instance Show (TypedSymbol t) where + show (TypedSymbol s) = show s ++ " :: " ++ show (typeRep @t) + +instance Lift (TypedSymbol t) where + liftTyped (TypedSymbol s) = [||TypedSymbol s||] + -} + +data SomeTypedSymbol where + SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol + +instance NFData SomeTypedSymbol where + rnf (SomeTypedSymbol p s) = rnf (SomeTypeRep p) `seq` rnf s + +instance Eq SomeTypedSymbol where + (SomeTypedSymbol t1 s1) == (SomeTypedSymbol t2 s2) = case eqTypeRep t1 t2 of + Just HRefl -> s1 == s2 + _ -> False + +instance Ord SomeTypedSymbol where + (SomeTypedSymbol t1 s1) <= (SomeTypedSymbol t2 s2) = + SomeTypeRep t1 < SomeTypeRep t2 + || ( case eqTypeRep t1 t2 of + Just HRefl -> s1 <= s2 + _ -> False + ) + +instance Hashable SomeTypedSymbol where + hashWithSalt s (SomeTypedSymbol t1 s1) = s `hashWithSalt` s1 `hashWithSalt` t1 + +instance Show SomeTypedSymbol where + show (SomeTypedSymbol _ s) = show s + +someTypedSymbol :: forall t. TypedSymbol t -> SomeTypedSymbol +someTypedSymbol s@(SimpleSymbol _) = SomeTypedSymbol (typeRep @t) s +someTypedSymbol s@(IndexedSymbol _ _) = SomeTypedSymbol (typeRep @t) s +someTypedSymbol s@(WithInfo _ _) = SomeTypedSymbol (typeRep @t) s + +data Term t where + ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t + SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t + UnaryTerm :: + (UnaryOp tag arg t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg) -> + Term t + BinaryTerm :: + (BinaryOp tag arg1 arg2 t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg1) -> + !(Term arg2) -> + Term t + TernaryTerm :: + (TernaryOp tag arg1 arg2 arg3 t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg1) -> + !(Term arg2) -> + !(Term arg3) -> + Term t + NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool + OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool + AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool + EqvTerm :: SupportedPrim t => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool + ITETerm :: SupportedPrim t => {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term t) -> !(Term t) -> Term t + AddNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + UMinusNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + TimesNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + AbsNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + SignumNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + LTNumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool + LENumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool + AndBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + OrBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + XorBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + ComplementBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + ShiftBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> {-# UNPACK #-} !Int -> Term t + RotateBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> {-# UNPACK #-} !Int -> Term t + BVConcatTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + SupportedPrim (bv c), + KnownNat a, + KnownNat b, + KnownNat c, + BVConcat (bv a) (bv b) (bv c) + ) => + {-# UNPACK #-} !Id -> + !(Term (bv a)) -> + !(Term (bv b)) -> + Term (bv c) + BVSelectTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat w, + KnownNat ix, + BVSelect (bv a) ix w (bv w) + ) => + {-# UNPACK #-} !Id -> + !(TypeRep ix) -> + !(TypeRep w) -> + !(Term (bv a)) -> + Term (bv w) + BVExtendTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b) + ) => + {-# UNPACK #-} !Id -> + !Bool -> + !(TypeRep n) -> + !(Term (bv a)) -> + Term (bv b) + TabularFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + {-# UNPACK #-} !Id -> + Term (a =-> b) -> + Term a -> + Term b + GeneralFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + {-# UNPACK #-} !Id -> + Term (a --> b) -> + Term a -> + Term b + DivIntegerTerm :: !Id -> Term Integer -> Term Integer -> Term Integer + ModIntegerTerm :: !Id -> Term Integer -> Term Integer -> Term Integer + +instance NFData (Term a) where + rnf i = identity i `seq` () + +instance Lift (Term t) where + lift = unTypeSplice . liftTyped + liftTyped (ConTerm _ i) = [||conTerm i||] + liftTyped (SymTerm _ sym) = [||symTerm sym||] + liftTyped (UnaryTerm _ tag arg) = [||constructUnary tag arg||] + liftTyped (BinaryTerm _ tag arg1 arg2) = [||constructBinary tag arg1 arg2||] + liftTyped (TernaryTerm _ tag arg1 arg2 arg3) = [||constructTernary tag arg1 arg2 arg3||] + liftTyped (NotTerm _ arg) = [||notTerm arg||] + liftTyped (OrTerm _ arg1 arg2) = [||orTerm arg1 arg2||] + liftTyped (AndTerm _ arg1 arg2) = [||andTerm arg1 arg2||] + liftTyped (EqvTerm _ arg1 arg2) = [||eqvTerm arg1 arg2||] + liftTyped (ITETerm _ cond arg1 arg2) = [||iteTerm cond arg1 arg2||] + liftTyped (AddNumTerm _ arg1 arg2) = [||addNumTerm arg1 arg2||] + liftTyped (UMinusNumTerm _ arg) = [||uminusNumTerm arg||] + liftTyped (TimesNumTerm _ arg1 arg2) = [||timesNumTerm arg1 arg2||] + liftTyped (AbsNumTerm _ arg) = [||absNumTerm arg||] + liftTyped (SignumNumTerm _ arg) = [||signumNumTerm arg||] + liftTyped (LTNumTerm _ arg1 arg2) = [||ltNumTerm arg1 arg2||] + liftTyped (LENumTerm _ arg1 arg2) = [||leNumTerm arg1 arg2||] + liftTyped (AndBitsTerm _ arg1 arg2) = [||andBitsTerm arg1 arg2||] + liftTyped (OrBitsTerm _ arg1 arg2) = [||orBitsTerm arg1 arg2||] + liftTyped (XorBitsTerm _ arg1 arg2) = [||xorBitsTerm arg1 arg2||] + liftTyped (ComplementBitsTerm _ arg) = [||complementBitsTerm arg||] + liftTyped (ShiftBitsTerm _ arg n) = [||shiftBitsTerm arg n||] + liftTyped (RotateBitsTerm _ arg n) = [||rotateBitsTerm arg n||] + liftTyped (BVConcatTerm _ arg1 arg2) = [||bvconcatTerm arg1 arg2||] + liftTyped (BVSelectTerm _ (_ :: TypeRep ix) (_ :: TypeRep w) arg) = [||bvselectTerm (Proxy @ix) (Proxy @w) arg||] + liftTyped (BVExtendTerm _ signed (_ :: TypeRep n) arg) = [||bvextendTerm signed (Proxy @n) arg||] + liftTyped (TabularFunApplyTerm _ func arg) = [||tabularFunApplyTerm func arg||] + liftTyped (GeneralFunApplyTerm _ func arg) = [||generalFunApplyTerm func arg||] + liftTyped (DivIntegerTerm _ arg1 arg2) = [||divIntegerTerm arg1 arg2||] + liftTyped (ModIntegerTerm _ arg1 arg2) = [||modIntegerTerm arg1 arg2||] + +instance Show (Term ty) where + show (ConTerm i v) = "ConTerm{id=" ++ show i ++ ", v=" ++ show v ++ "}" + show (SymTerm i name) = + "SymTerm{id=" + ++ show i + ++ ", name=" + ++ show name + ++ ", type=" + ++ show (typeRep @ty) + ++ "}" + show (UnaryTerm i tag arg) = "Unary{id=" ++ show i ++ ", tag=" ++ show tag ++ ", arg=" ++ show arg ++ "}" + show (BinaryTerm i tag arg1 arg2) = + "Binary{id=" + ++ show i + ++ ", tag=" + ++ show tag + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (TernaryTerm i tag arg1 arg2 arg3) = + "Ternary{id=" + ++ show i + ++ ", tag=" + ++ show tag + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ ", arg3=" + ++ show arg3 + ++ "}" + show (NotTerm i arg) = "Not{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (OrTerm i arg1 arg2) = "Or{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (AndTerm i arg1 arg2) = "And{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (EqvTerm i arg1 arg2) = "Eqv{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (ITETerm i cond l r) = + "ITE{id=" + ++ show i + ++ ", cond=" + ++ show cond + ++ ", then=" + ++ show l + ++ ", else=" + ++ show r + ++ "}" + show (AddNumTerm i arg1 arg2) = "AddNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (UMinusNumTerm i arg) = "UMinusNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (TimesNumTerm i arg1 arg2) = "TimesNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (AbsNumTerm i arg) = "AbsNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (SignumNumTerm i arg) = "SignumNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (LTNumTerm i arg1 arg2) = "LTNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (LENumTerm i arg1 arg2) = "LENum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (AndBitsTerm i arg1 arg2) = "AndBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (OrBitsTerm i arg1 arg2) = "OrBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (XorBitsTerm i arg1 arg2) = "XorBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (ComplementBitsTerm i arg) = "ComplementBits{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (ShiftBitsTerm i arg n) = "ShiftBits{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" + show (RotateBitsTerm i arg n) = "RotateBits{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" + show (BVConcatTerm i arg1 arg2) = "BVConcat{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (BVSelectTerm i ix w arg) = + "BVSelect{id=" ++ show i ++ ", ix=" ++ show ix ++ ", w=" ++ show w ++ ", arg=" ++ show arg ++ "}" + show (BVExtendTerm i signed n arg) = + "BVExtend{id=" ++ show i ++ ", signed=" ++ show signed ++ ", n=" ++ show n ++ ", arg=" ++ show arg ++ "}" + show (TabularFunApplyTerm i func arg) = + "TabularFunApply{id=" ++ show i ++ ", func=" ++ show func ++ ", arg=" ++ show arg ++ "}" + show (GeneralFunApplyTerm i func arg) = + "GeneralFunApply{id=" ++ show i ++ ", func=" ++ show func ++ ", arg=" ++ show arg ++ "}" + show (DivIntegerTerm i arg1 arg2) = + "DivInteger{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (ModIntegerTerm i arg1 arg2) = + "ModInteger{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + +instance (SupportedPrim t) => Eq (Term t) where + (==) = (==) `on` identity + +instance (SupportedPrim t) => Hashable (Term t) where + hashWithSalt s t = hashWithSalt s $ identity t + +data UTerm t where + UConTerm :: (SupportedPrim t) => !t -> UTerm t + USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t + UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t + UBinaryTerm :: + (BinaryOp tag arg1 arg2 t) => + !tag -> + !(Term arg1) -> + !(Term arg2) -> + UTerm t + UTernaryTerm :: + (TernaryOp tag arg1 arg2 arg3 t) => + !tag -> + !(Term arg1) -> + !(Term arg2) -> + !(Term arg3) -> + UTerm t + UNotTerm :: !(Term Bool) -> UTerm Bool + UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UEqvTerm :: SupportedPrim t => !(Term t) -> !(Term t) -> UTerm Bool + UITETerm :: SupportedPrim t => !(Term Bool) -> !(Term t) -> !(Term t) -> UTerm t + UAddNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t + UUMinusNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t + UTimesNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t + UAbsNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t + USignumNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t + ULTNumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool + ULENumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool + UAndBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t + UOrBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t + UXorBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t + UComplementBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> UTerm t + UShiftBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> {-# UNPACK #-} !Int -> UTerm t + URotateBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> {-# UNPACK #-} !Int -> UTerm t + UBVConcatTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + SupportedPrim (bv c), + KnownNat a, + KnownNat b, + KnownNat c, + BVConcat (bv a) (bv b) (bv c) + ) => + !(Term (bv a)) -> + !(Term (bv b)) -> + UTerm (bv c) + UBVSelectTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat ix, + KnownNat w, + BVSelect (bv a) ix w (bv w) + ) => + !(TypeRep ix) -> + !(TypeRep w) -> + !(Term (bv a)) -> + UTerm (bv w) + UBVExtendTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b) + ) => + !Bool -> + !(TypeRep n) -> + !(Term (bv a)) -> + UTerm (bv b) + UTabularFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + Term (a =-> b) -> + Term a -> + UTerm b + UGeneralFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + Term (a --> b) -> + Term a -> + UTerm b + UDivIntegerTerm :: Term Integer -> Term Integer -> UTerm Integer + UModIntegerTerm :: Term Integer -> Term Integer -> UTerm Integer + +eqTypedId :: (TypeRep a, Id) -> (TypeRep b, Id) -> Bool +eqTypedId (a, i1) (b, i2) = i1 == i2 && eqTypeRepBool a b +{-# INLINE eqTypedId #-} + +eqHeteroTag :: Eq a => (TypeRep a, a) -> (TypeRep b, b) -> Bool +eqHeteroTag (tpa, taga) (tpb, tagb) = eqHeteroRep tpa tpb taga tagb +{-# INLINE eqHeteroTag #-} + +instance (SupportedPrim t) => Interned (Term t) where + type Uninterned (Term t) = UTerm t + data Description (Term t) where + DConTerm :: t -> Description (Term t) + DSymTerm :: TypedSymbol t -> Description (Term t) + DUnaryTerm :: + (Eq tag, Hashable tag) => + {-# UNPACK #-} !(TypeRep tag, tag) -> + {-# UNPACK #-} !(TypeRep arg, Id) -> + Description (Term t) + DBinaryTerm :: + (Eq tag, Hashable tag) => + {-# UNPACK #-} !(TypeRep tag, tag) -> + {-# UNPACK #-} !(TypeRep arg1, Id) -> + {-# UNPACK #-} !(TypeRep arg2, Id) -> + Description (Term t) + DTernaryTerm :: + (Eq tag, Hashable tag) => + {-# UNPACK #-} !(TypeRep tag, tag) -> + {-# UNPACK #-} !(TypeRep arg1, Id) -> + {-# UNPACK #-} !(TypeRep arg2, Id) -> + {-# UNPACK #-} !(TypeRep arg3, Id) -> + Description (Term t) + DNotTerm :: {-# UNPACK #-} !Id -> Description (Term Bool) + DOrTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DAndTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DEqvTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DITETerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DAddNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DUMinusNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DTimesNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DAbsNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DSignumNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DLTNumTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DLENumTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DAndBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DOrBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DXorBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DComplementBitsTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DShiftBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Int -> Description (Term t) + DRotateBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Int -> Description (Term t) + DBVConcatTerm :: TypeRep bv1 -> TypeRep bv2 -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DBVSelectTerm :: + forall bv (a :: Nat) (w :: Nat) (ix :: Nat). + !(TypeRep ix) -> + !(TypeRep (bv a), Id) -> + Description (Term (bv w)) + DBVExtendTerm :: + forall bv (a :: Nat) (b :: Nat) (n :: Nat). + !Bool -> + !(TypeRep n) -> + {-# UNPACK #-} !(TypeRep (bv a), Id) -> + Description (Term (bv b)) + DTabularFunApplyTerm :: + {-# UNPACK #-} !(TypeRep (a =-> b), Id) -> + {-# UNPACK #-} !(TypeRep a, Id) -> + Description (Term b) + DGeneralFunApplyTerm :: + {-# UNPACK #-} !(TypeRep (a --> b), Id) -> + {-# UNPACK #-} !(TypeRep a, Id) -> + Description (Term b) + DDivIntegerTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Integer) + DModIntegerTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Integer) + + describe (UConTerm v) = DConTerm v + describe ((USymTerm name) :: UTerm t) = DSymTerm @t name + describe ((UUnaryTerm (tag :: tagt) (tm :: Term arg)) :: UTerm t) = + DUnaryTerm (typeRep, tag) (typeRep :: TypeRep arg, identity tm) + describe ((UBinaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2)) :: UTerm t) = + DBinaryTerm @tagt @arg1 @arg2 @t (typeRep, tag) (typeRep, identity tm1) (typeRep, identity tm2) + describe ((UTernaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2) (tm3 :: Term arg3)) :: UTerm t) = + DTernaryTerm @tagt @arg1 @arg2 @arg3 @t + (typeRep, tag) + (typeRep, identity tm1) + (typeRep, identity tm2) + (typeRep, identity tm3) + describe (UNotTerm arg) = DNotTerm (identity arg) + describe (UOrTerm arg1 arg2) = DOrTerm (identity arg1) (identity arg2) + describe (UAndTerm arg1 arg2) = DAndTerm (identity arg1) (identity arg2) + describe (UEqvTerm (arg1 :: Term arg) arg2) = DEqvTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) + describe (UITETerm cond (l :: Term arg) r) = DITETerm (identity cond) (identity l) (identity r) + describe (UAddNumTerm arg1 arg2) = DAddNumTerm (identity arg1) (identity arg2) + describe (UUMinusNumTerm arg) = DUMinusNumTerm (identity arg) + describe (UTimesNumTerm arg1 arg2) = DTimesNumTerm (identity arg1) (identity arg2) + describe (UAbsNumTerm arg) = DAbsNumTerm (identity arg) + describe (USignumNumTerm arg) = DSignumNumTerm (identity arg) + describe (ULTNumTerm (arg1 :: arg) arg2) = DLTNumTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) + describe (ULENumTerm (arg1 :: arg) arg2) = DLENumTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) + describe (UAndBitsTerm arg1 arg2) = DAndBitsTerm (identity arg1) (identity arg2) + describe (UOrBitsTerm arg1 arg2) = DOrBitsTerm (identity arg1) (identity arg2) + describe (UXorBitsTerm arg1 arg2) = DXorBitsTerm (identity arg1) (identity arg2) + describe (UComplementBitsTerm arg) = DComplementBitsTerm (identity arg) + describe (UShiftBitsTerm arg n) = DShiftBitsTerm (identity arg) n + describe (URotateBitsTerm arg n) = DRotateBitsTerm (identity arg) n + describe (UBVConcatTerm (arg1 :: bv1) (arg2 :: bv2)) = + DBVConcatTerm (typeRep :: TypeRep bv1) (typeRep :: TypeRep bv2) (identity arg1) (identity arg2) + describe (UBVSelectTerm (ix :: TypeRep ix) _ (arg :: Term arg)) = + DBVSelectTerm ix (typeRep :: TypeRep arg, identity arg) + describe (UBVExtendTerm signed (n :: TypeRep n) (arg :: Term arg)) = + DBVExtendTerm signed n (typeRep :: TypeRep arg, identity arg) + describe (UTabularFunApplyTerm (func :: Term f) (arg :: Term a)) = + DTabularFunApplyTerm (typeRep :: TypeRep f, identity func) (typeRep :: TypeRep a, identity arg) + describe (UGeneralFunApplyTerm (func :: Term f) (arg :: Term a)) = + DGeneralFunApplyTerm (typeRep :: TypeRep f, identity func) (typeRep :: TypeRep a, identity arg) + describe (UDivIntegerTerm arg1 arg2) = DDivIntegerTerm (identity arg1) (identity arg2) + describe (UModIntegerTerm arg1 arg2) = DModIntegerTerm (identity arg1) (identity arg2) + identify i = go + where + go (UConTerm v) = ConTerm i v + go (USymTerm v) = SymTerm i v + go (UUnaryTerm tag tm) = UnaryTerm i tag tm + go (UBinaryTerm tag tm1 tm2) = BinaryTerm i tag tm1 tm2 + go (UTernaryTerm tag tm1 tm2 tm3) = TernaryTerm i tag tm1 tm2 tm3 + go (UNotTerm arg) = NotTerm i arg + go (UOrTerm arg1 arg2) = OrTerm i arg1 arg2 + go (UAndTerm arg1 arg2) = AndTerm i arg1 arg2 + go (UEqvTerm arg1 arg2) = EqvTerm i arg1 arg2 + go (UITETerm cond l r) = ITETerm i cond l r + go (UAddNumTerm arg1 arg2) = AddNumTerm i arg1 arg2 + go (UUMinusNumTerm arg) = UMinusNumTerm i arg + go (UTimesNumTerm arg1 arg2) = TimesNumTerm i arg1 arg2 + go (UAbsNumTerm arg) = AbsNumTerm i arg + go (USignumNumTerm arg) = SignumNumTerm i arg + go (ULTNumTerm arg1 arg2) = LTNumTerm i arg1 arg2 + go (ULENumTerm arg1 arg2) = LENumTerm i arg1 arg2 + go (UAndBitsTerm arg1 arg2) = AndBitsTerm i arg1 arg2 + go (UOrBitsTerm arg1 arg2) = OrBitsTerm i arg1 arg2 + go (UXorBitsTerm arg1 arg2) = XorBitsTerm i arg1 arg2 + go (UComplementBitsTerm arg) = ComplementBitsTerm i arg + go (UShiftBitsTerm arg n) = ShiftBitsTerm i arg n + go (URotateBitsTerm arg n) = RotateBitsTerm i arg n + go (UBVConcatTerm arg1 arg2) = BVConcatTerm i arg1 arg2 + go (UBVSelectTerm ix w arg) = BVSelectTerm i ix w arg + go (UBVExtendTerm signed n arg) = BVExtendTerm i signed n arg + go (UTabularFunApplyTerm func arg) = TabularFunApplyTerm i func arg + go (UGeneralFunApplyTerm func arg) = GeneralFunApplyTerm i func arg + go (UDivIntegerTerm arg1 arg2) = DivIntegerTerm i arg1 arg2 + go (UModIntegerTerm arg1 arg2) = ModIntegerTerm i arg1 arg2 + cache = termCache + +instance (SupportedPrim t) => Eq (Description (Term t)) where + DConTerm (l :: tyl) == DConTerm (r :: tyr) = cast @tyl @tyr l == Just r + DSymTerm ls == DSymTerm rs = ls == rs + DUnaryTerm (tagl :: tagl) li == DUnaryTerm (tagr :: tagr) ri = eqHeteroTag tagl tagr && eqTypedId li ri + DBinaryTerm (tagl :: tagl) li1 li2 == DBinaryTerm (tagr :: tagr) ri1 ri2 = + eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 + DTernaryTerm (tagl :: tagl) li1 li2 li3 == DTernaryTerm (tagr :: tagr) ri1 ri2 ri3 = + eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 && eqTypedId li3 ri3 + DNotTerm li == DNotTerm ri = li == ri + DOrTerm li1 li2 == DOrTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DAndTerm li1 li2 == DAndTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DEqvTerm lrep li1 li2 == DEqvTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 + DITETerm lc li1 li2 == DITETerm rc ri1 ri2 = lc == rc && li1 == ri1 && li2 == ri2 + DAddNumTerm li1 li2 == DAddNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DUMinusNumTerm li == DUMinusNumTerm ri = li == ri + DTimesNumTerm li1 li2 == DTimesNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DAbsNumTerm li == DAbsNumTerm ri = li == ri + DSignumNumTerm li == DSignumNumTerm ri = li == ri + DLTNumTerm lrep li1 li2 == DLTNumTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 + DLENumTerm lrep li1 li2 == DLENumTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 + DAndBitsTerm li1 li2 == DAndBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DOrBitsTerm li1 li2 == DOrBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DXorBitsTerm li1 li2 == DXorBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DComplementBitsTerm li == DComplementBitsTerm ri = li == ri + DShiftBitsTerm li ln == DShiftBitsTerm ri rn = li == ri && ln == rn + DRotateBitsTerm li ln == DRotateBitsTerm ri rn = li == ri && ln == rn + DBVConcatTerm lrep1 lrep2 li1 li2 == DBVConcatTerm rrep1 rrep2 ri1 ri2 = + eqTypeRepBool lrep1 rrep1 && eqTypeRepBool lrep2 rrep2 && li1 == ri1 && li2 == ri2 + DBVSelectTerm lix li == DBVSelectTerm rix ri = + eqTypeRepBool lix rix && eqTypedId li ri + DBVExtendTerm lIsSigned ln li == DBVExtendTerm rIsSigned rn ri = + lIsSigned == rIsSigned + && eqTypeRepBool ln rn + && eqTypedId li ri + DTabularFunApplyTerm lf li == DTabularFunApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri + DGeneralFunApplyTerm lf li == DGeneralFunApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri + DDivIntegerTerm li1 li2 == DDivIntegerTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DModIntegerTerm li1 li2 == DModIntegerTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + _ == _ = False + +instance (SupportedPrim t) => Hashable (Description (Term t)) where + hashWithSalt s (DConTerm c) = s `hashWithSalt` (0 :: Int) `hashWithSalt` c + hashWithSalt s (DSymTerm name) = s `hashWithSalt` (1 :: Int) `hashWithSalt` name + hashWithSalt s (DUnaryTerm tag id1) = s `hashWithSalt` (2 :: Int) `hashWithSalt` tag `hashWithSalt` id1 + hashWithSalt s (DBinaryTerm tag id1 id2) = + s `hashWithSalt` (3 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DTernaryTerm tag id1 id2 id3) = + s `hashWithSalt` (4 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 `hashWithSalt` id3 + hashWithSalt s (DNotTerm id1) = s `hashWithSalt` (5 :: Int) `hashWithSalt` id1 + hashWithSalt s (DOrTerm id1 id2) = s `hashWithSalt` (6 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DAndTerm id1 id2) = s `hashWithSalt` (7 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DEqvTerm rep id1 id2) = + s + `hashWithSalt` (8 :: Int) + `hashWithSalt` rep + `hashWithSalt` id1 + `hashWithSalt` id2 + hashWithSalt s (DITETerm idc id1 id2) = + s + `hashWithSalt` (9 :: Int) + `hashWithSalt` idc + `hashWithSalt` id1 + `hashWithSalt` id2 + hashWithSalt s (DAddNumTerm id1 id2) = s `hashWithSalt` (10 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DUMinusNumTerm id1) = s `hashWithSalt` (11 :: Int) `hashWithSalt` id1 + hashWithSalt s (DTimesNumTerm id1 id2) = s `hashWithSalt` (12 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DAbsNumTerm id1) = s `hashWithSalt` (13 :: Int) `hashWithSalt` id1 + hashWithSalt s (DSignumNumTerm id1) = s `hashWithSalt` (14 :: Int) `hashWithSalt` id1 + hashWithSalt s (DLTNumTerm rep id1 id2) = + s `hashWithSalt` (15 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DLENumTerm rep id1 id2) = + s `hashWithSalt` (16 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DAndBitsTerm id1 id2) = s `hashWithSalt` (17 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DOrBitsTerm id1 id2) = s `hashWithSalt` (18 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DXorBitsTerm id1 id2) = s `hashWithSalt` (19 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DComplementBitsTerm id1) = s `hashWithSalt` (20 :: Int) `hashWithSalt` id1 + hashWithSalt s (DShiftBitsTerm id1 n) = s `hashWithSalt` (21 :: Int) `hashWithSalt` id1 `hashWithSalt` n + hashWithSalt s (DRotateBitsTerm id1 n) = s `hashWithSalt` (22 :: Int) `hashWithSalt` id1 `hashWithSalt` n + hashWithSalt s (DBVConcatTerm rep1 rep2 id1 id2) = + s `hashWithSalt` (23 :: Int) `hashWithSalt` rep1 `hashWithSalt` rep2 `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DBVSelectTerm ix id1) = s `hashWithSalt` (24 :: Int) `hashWithSalt` ix `hashWithSalt` id1 + hashWithSalt s (DBVExtendTerm signed n id1) = + s + `hashWithSalt` (25 :: Int) + `hashWithSalt` signed + `hashWithSalt` n + `hashWithSalt` id1 + hashWithSalt s (DTabularFunApplyTerm id1 id2) = s `hashWithSalt` (26 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DGeneralFunApplyTerm id1 id2) = s `hashWithSalt` (27 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DDivIntegerTerm id1 id2) = s `hashWithSalt` (28 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DModIntegerTerm id1 id2) = s `hashWithSalt` (29 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + +-- Basic Bool +defaultValueForBool :: Bool +defaultValueForBool = False + +defaultValueForBoolDyn :: ModelValue +defaultValueForBoolDyn = toModelValue defaultValueForBool + +instance SupportedPrim Bool where + pformatCon True = "true" + pformatCon False = "false" + defaultValue = defaultValueForBool + defaultValueDynamic _ = defaultValueForBoolDyn + +defaultValueForInteger :: Integer +defaultValueForInteger = 0 + +defaultValueForIntegerDyn :: ModelValue +defaultValueForIntegerDyn = toModelValue defaultValueForInteger + +-- Basic Integer +instance SupportedPrim Integer where + pformatCon = show + defaultValue = defaultValueForInteger + defaultValueDynamic _ = defaultValueForIntegerDyn + +-- Signed BV +instance (KnownNat w, 1 <= w) => SupportedPrim (IntN w) where + type PrimConstraint (IntN w) = (KnownNat w, 1 <= w) + pformatCon = show + defaultValue = 0 + +-- Unsigned BV +instance (KnownNat w, 1 <= w) => SupportedPrim (WordN w) where + type PrimConstraint (WordN w) = (KnownNat w, 1 <= w) + pformatCon = show + defaultValue = 0 + +data FunArg = FunArg deriving (Show, Eq, Generic, Ord, Lift, Hashable, NFData) + +-- | General symbolic function type. Use the '#' operator to apply the function. +-- Note that this function should be applied to symbolic values only. It is by +-- itself already a symbolic value, but can be considered partially concrete +-- as the function body is specified. Use 'Grisette.IR.SymPrim.Data.SymPrim.-~>' for uninterpreted general +-- symbolic functions. +-- +-- The result would be partially evaluated. +-- +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeOperators +-- >>> let f = ("x" :: TypedSymbol Integer) --> ("x" + 1 + "y" :: SymInteger) :: Integer --> Integer +-- >>> f # 1 -- 1 has the type SymInteger +-- (+ 2 y) +-- >>> f # "a" -- "a" has the type SymInteger +-- (+ 1 (+ a y)) +data (-->) a b where + GeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b + +infixr 0 --> + +instance Eq (a --> b) where + GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2 + +instance Show (a --> b) where + show (GeneralFun sym tm) = "\\(" ++ show sym ++ ") -> " ++ pformat tm + +instance Lift (a --> b) where + liftTyped (GeneralFun sym tm) = [||GeneralFun sym tm||] + +instance Hashable (a --> b) where + s `hashWithSalt` (GeneralFun sym tm) = s `hashWithSalt` sym `hashWithSalt` tm + +instance NFData (a --> b) where + rnf (GeneralFun sym tm) = rnf sym `seq` rnf tm + +instance (SupportedPrim a, SupportedPrim b) => SupportedPrim (a --> b) where + type PrimConstraint (a --> b) = (SupportedPrim a, SupportedPrim b) + defaultValue = GeneralFun (WithInfo (SimpleSymbol "a") FunArg) (conTerm defaultValue) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot @@ -0,0 +1,308 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + ( SupportedPrim (..), + UnaryOp (..), + BinaryOp (..), + TernaryOp (..), + TypedSymbol (..), + SomeTypedSymbol (..), + Term (..), + UTerm (..), + type (-->) (..), + ) +where + +import Control.DeepSeq +import Data.Bits +import Data.Hashable +import Data.Interned +import Data.Kind +import GHC.TypeNats +import Grisette.Core.Data.Class.BitVector +import Grisette.Core.Data.Class.Function +import Grisette.IR.SymPrim.Data.Prim.ModelValue +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.TabularFun +import Language.Haskell.TH.Syntax +import Type.Reflection + +class (Lift t, Typeable t, Hashable t, Eq t, Show t, NFData t) => SupportedPrim t where + type PrimConstraint t :: Constraint + type PrimConstraint t = () + default withPrim :: PrimConstraint t => proxy t -> (PrimConstraint t => a) -> a + withPrim :: proxy t -> (PrimConstraint t => a) -> a + withPrim _ i = i + termCache :: Cache (Term t) + termCache = typeMemoizedCache + pformatCon :: t -> String + default pformatCon :: (Show t) => t -> String + pformatCon = show + pformatSym :: TypedSymbol t -> String + pformatSym _ = showUntyped + defaultValue :: t + defaultValueDynamic :: proxy t -> ModelValue + defaultValueDynamic _ = toModelValue (defaultValue @t) + +class + (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) => + UnaryOp tag arg t + | tag arg -> t + where + partialEvalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t + pformatUnary :: tag -> Term arg -> String + +class + ( SupportedPrim arg1, + SupportedPrim arg2, + SupportedPrim t, + Lift tag, + NFData tag, + Show tag, + Typeable tag, + Eq tag, + Hashable tag + ) => + BinaryOp tag arg1 arg2 t + | tag arg1 arg2 -> t + where + partialEvalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t + pformatBinary :: tag -> Term arg1 -> Term arg2 -> String + +class + ( SupportedPrim arg1, + SupportedPrim arg2, + SupportedPrim arg3, + SupportedPrim t, + Lift tag, + NFData tag, + Show tag, + Typeable tag, + Eq tag, + Hashable tag + ) => + TernaryOp tag arg1 arg2 arg3 t + | tag arg1 arg2 arg3 -> t + where + partialEvalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t + pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String + +data TypedSymbol t where + SimpleSymbol :: SupportedPrim t => String -> TypedSymbol t + IndexedSymbol :: SupportedPrim t => String -> Int -> TypedSymbol t + WithInfo :: + forall t a. + ( SupportedPrim t, + Typeable a, + Ord a, + Lift a, + NFData a, + Show a, + Hashable a + ) => + TypedSymbol t -> + a -> + TypedSymbol t + +data SomeTypedSymbol where + SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol + +data Term t where + ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t + SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t + UnaryTerm :: + (UnaryOp tag arg t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg) -> + Term t + BinaryTerm :: + (BinaryOp tag arg1 arg2 t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg1) -> + !(Term arg2) -> + Term t + TernaryTerm :: + (TernaryOp tag arg1 arg2 arg3 t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg1) -> + !(Term arg2) -> + !(Term arg3) -> + Term t + NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool + OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool + AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool + EqvTerm :: SupportedPrim t => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool + ITETerm :: SupportedPrim t => {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term t) -> !(Term t) -> Term t + AddNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + UMinusNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + TimesNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + AbsNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + SignumNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + LTNumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool + LENumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool + AndBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + OrBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + XorBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + ComplementBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + ShiftBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> {-# UNPACK #-} !Int -> Term t + RotateBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> {-# UNPACK #-} !Int -> Term t + BVConcatTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + SupportedPrim (bv c), + KnownNat a, + KnownNat b, + KnownNat c, + BVConcat (bv a) (bv b) (bv c) + ) => + {-# UNPACK #-} !Id -> + !(Term (bv a)) -> + !(Term (bv b)) -> + Term (bv c) + BVSelectTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat w, + KnownNat ix, + BVSelect (bv a) ix w (bv w) + ) => + {-# UNPACK #-} !Id -> + !(TypeRep ix) -> + !(TypeRep w) -> + !(Term (bv a)) -> + Term (bv w) + BVExtendTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b) + ) => + {-# UNPACK #-} !Id -> + !Bool -> + !(TypeRep n) -> + !(Term (bv a)) -> + Term (bv b) + TabularFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + {-# UNPACK #-} !Id -> + Term (a =-> b) -> + Term a -> + Term b + GeneralFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + {-# UNPACK #-} !Id -> + Term (a --> b) -> + Term a -> + Term b + DivIntegerTerm :: !Id -> Term Integer -> Term Integer -> Term Integer + ModIntegerTerm :: !Id -> Term Integer -> Term Integer -> Term Integer + +data UTerm t where + UConTerm :: (SupportedPrim t) => !t -> UTerm t + USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t + UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t + UBinaryTerm :: + (BinaryOp tag arg1 arg2 t) => + !tag -> + !(Term arg1) -> + !(Term arg2) -> + UTerm t + UTernaryTerm :: + (TernaryOp tag arg1 arg2 arg3 t) => + !tag -> + !(Term arg1) -> + !(Term arg2) -> + !(Term arg3) -> + UTerm t + UNotTerm :: !(Term Bool) -> UTerm Bool + UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UEqvTerm :: SupportedPrim t => !(Term t) -> !(Term t) -> UTerm Bool + UITETerm :: SupportedPrim t => !(Term Bool) -> !(Term t) -> !(Term t) -> UTerm t + UAddNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t + UUMinusNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t + UTimesNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t + UAbsNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t + USignumNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t + ULTNumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool + ULENumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool + UAndBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t + UOrBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t + UXorBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t + UComplementBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> UTerm t + UShiftBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> {-# UNPACK #-} !Int -> UTerm t + URotateBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> {-# UNPACK #-} !Int -> UTerm t + UBVConcatTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + SupportedPrim (bv c), + KnownNat a, + KnownNat b, + KnownNat c, + BVConcat (bv a) (bv b) (bv c) + ) => + !(Term (bv a)) -> + !(Term (bv b)) -> + UTerm (bv c) + UBVSelectTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat ix, + KnownNat w, + BVSelect (bv a) ix w (bv w) + ) => + !(TypeRep ix) -> + !(TypeRep w) -> + !(Term (bv a)) -> + UTerm (bv w) + UBVExtendTerm :: + ( SupportedPrim (bv a), + SupportedPrim (bv b), + KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b) + ) => + !Bool -> + !(TypeRep n) -> + !(Term (bv a)) -> + UTerm (bv b) + UTabularFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + Term (a =-> b) -> + Term a -> + UTerm b + UGeneralFunApplyTerm :: + ( SupportedPrim a, + SupportedPrim b + ) => + Term (a --> b) -> + Term a -> + UTerm b + UDivIntegerTerm :: Term Integer -> Term Integer -> UTerm Integer + UModIntegerTerm :: Term Integer -> Term Integer -> UTerm Integer + +data (-->) a b where + GeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b + +infixr 0 --> diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution (substTerm) where + +import Grisette.Core.Data.MemoUtils +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +import Type.Reflection +import Unsafe.Coerce + +substTerm :: forall a b. (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term a -> Term b -> Term b +substTerm sym term = gov + where + gov :: (SupportedPrim x) => Term x -> Term x + gov b = case go (SomeTerm b) of + SomeTerm v -> unsafeCoerce v + go :: SomeTerm -> SomeTerm + go = htmemo $ \stm@(SomeTerm (tm :: Term v)) -> + case tm of + ConTerm _ cv -> case (typeRep :: TypeRep v) of + App (App gf _) _ -> + case eqTypeRep gf (typeRep @(-->)) of + Just HRefl -> case cv of + GeneralFun sym1 tm1 -> + if someTypedSymbol sym1 == someTypedSymbol sym + then stm + else SomeTerm $ conTerm $ GeneralFun sym1 (gov tm1) + Nothing -> stm + _ -> stm + SymTerm _ ts -> SomeTerm $ if someTypedSymbol ts == someTypedSymbol sym then unsafeCoerce term else tm + UnaryTerm _ tag te -> SomeTerm $ partialEvalUnary tag (gov te) + BinaryTerm _ tag te te' -> SomeTerm $ partialEvalBinary tag (gov te) (gov te') + TernaryTerm _ tag op1 op2 op3 -> SomeTerm $ partialEvalTernary tag (gov op1) (gov op2) (gov op3) + NotTerm _ op -> SomeTerm $ pevalNotTerm (gov op) + OrTerm _ op1 op2 -> SomeTerm $ pevalOrTerm (gov op1) (gov op2) + AndTerm _ op1 op2 -> SomeTerm $ pevalAndTerm (gov op1) (gov op2) + EqvTerm _ op1 op2 -> SomeTerm $ pevalEqvTerm (gov op1) (gov op2) + ITETerm _ c op1 op2 -> SomeTerm $ pevalITETerm (gov c) (gov op1) (gov op2) + AddNumTerm _ op1 op2 -> SomeTerm $ pevalAddNumTerm (gov op1) (gov op2) + UMinusNumTerm _ op -> SomeTerm $ pevalUMinusNumTerm (gov op) + TimesNumTerm _ op1 op2 -> SomeTerm $ pevalTimesNumTerm (gov op1) (gov op2) + AbsNumTerm _ op -> SomeTerm $ pevalAbsNumTerm (gov op) + SignumNumTerm _ op -> SomeTerm $ pevalSignumNumTerm (gov op) + LTNumTerm _ op1 op2 -> SomeTerm $ pevalLtNumTerm (gov op1) (gov op2) + LENumTerm _ op1 op2 -> SomeTerm $ pevalLeNumTerm (gov op1) (gov op2) + AndBitsTerm _ op1 op2 -> SomeTerm $ pevalAndBitsTerm (gov op1) (gov op2) + OrBitsTerm _ op1 op2 -> SomeTerm $ pevalOrBitsTerm (gov op1) (gov op2) + XorBitsTerm _ op1 op2 -> SomeTerm $ pevalXorBitsTerm (gov op1) (gov op2) + ComplementBitsTerm _ op -> SomeTerm $ pevalComplementBitsTerm (gov op) + ShiftBitsTerm _ op n -> SomeTerm $ pevalShiftBitsTerm (gov op) n + RotateBitsTerm _ op n -> SomeTerm $ pevalRotateBitsTerm (gov op) n + BVConcatTerm _ op1 op2 -> SomeTerm $ pevalBVConcatTerm (gov op1) (gov op2) + BVSelectTerm _ ix w op -> SomeTerm $ pevalBVSelectTerm ix w (gov op) + BVExtendTerm _ n signed op -> SomeTerm $ pevalBVExtendTerm n signed (gov op) + TabularFunApplyTerm _ f op -> SomeTerm $ pevalTabularFunApplyTerm (gov f) (gov op) + GeneralFunApplyTerm _ f op -> SomeTerm $ pevalGeneralFunApplyTerm (gov f) (gov op) + DivIntegerTerm _ op1 op2 -> SomeTerm $ pevalDivIntegerTerm (gov op1) (gov op2) + ModIntegerTerm _ op1 op2 -> SomeTerm $ pevalModIntegerTerm (gov op1) (gov op2) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} + +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution (substTerm) where + +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + +substTerm :: forall a b. (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term a -> Term b -> Term b diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils + ( identity, + identityWithTypeRep, + introSupportedPrimConstraint, + extractSymbolicsTerm, + castTerm, + pformat, + termSize, + termsSize, + ) +where + +import Control.Monad.State +import Data.HashMap.Strict as M +import Data.HashSet as S +import Data.Interned +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.TabularFun () +import qualified Type.Reflection as R + +identity :: Term t -> Id +identity (ConTerm i _) = i +identity (SymTerm i _) = i +identity (UnaryTerm i _ _) = i +identity (BinaryTerm i _ _ _) = i +identity (TernaryTerm i _ _ _ _) = i +identity (NotTerm i _) = i +identity (OrTerm i _ _) = i +identity (AndTerm i _ _) = i +identity (EqvTerm i _ _) = i +identity (ITETerm i _ _ _) = i +identity (AddNumTerm i _ _) = i +identity (UMinusNumTerm i _) = i +identity (TimesNumTerm i _ _) = i +identity (AbsNumTerm i _) = i +identity (SignumNumTerm i _) = i +identity (LTNumTerm i _ _) = i +identity (LENumTerm i _ _) = i +identity (AndBitsTerm i _ _) = i +identity (OrBitsTerm i _ _) = i +identity (XorBitsTerm i _ _) = i +identity (ComplementBitsTerm i _) = i +identity (ShiftBitsTerm i _ _) = i +identity (RotateBitsTerm i _ _) = i +identity (BVConcatTerm i _ _) = i +identity (BVSelectTerm i _ _ _) = i +identity (BVExtendTerm i _ _ _) = i +identity (TabularFunApplyTerm i _ _) = i +identity (GeneralFunApplyTerm i _ _) = i +identity (DivIntegerTerm i _ _) = i +identity (ModIntegerTerm i _ _) = i +{-# INLINE identity #-} + +identityWithTypeRep :: forall t. Term t -> (TypeRep, Id) +identityWithTypeRep (ConTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (SymTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (UnaryTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (BinaryTerm i _ _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (TernaryTerm i _ _ _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (NotTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (OrTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (AndTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (EqvTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (ITETerm i _ _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (AddNumTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (UMinusNumTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (TimesNumTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (AbsNumTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (SignumNumTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (LTNumTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (LENumTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (AndBitsTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (OrBitsTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (XorBitsTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (ComplementBitsTerm i _) = (typeRep (Proxy @t), i) +identityWithTypeRep (ShiftBitsTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (RotateBitsTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (BVConcatTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (BVSelectTerm i _ _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (BVExtendTerm i _ _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (TabularFunApplyTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (GeneralFunApplyTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (DivIntegerTerm i _ _) = (typeRep (Proxy @t), i) +identityWithTypeRep (ModIntegerTerm i _ _) = (typeRep (Proxy @t), i) +{-# INLINE identityWithTypeRep #-} + +introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a +introSupportedPrimConstraint ConTerm {} x = x +introSupportedPrimConstraint SymTerm {} x = x +introSupportedPrimConstraint UnaryTerm {} x = x +introSupportedPrimConstraint BinaryTerm {} x = x +introSupportedPrimConstraint TernaryTerm {} x = x +introSupportedPrimConstraint NotTerm {} x = x +introSupportedPrimConstraint OrTerm {} x = x +introSupportedPrimConstraint AndTerm {} x = x +introSupportedPrimConstraint EqvTerm {} x = x +introSupportedPrimConstraint ITETerm {} x = x +introSupportedPrimConstraint AddNumTerm {} x = x +introSupportedPrimConstraint UMinusNumTerm {} x = x +introSupportedPrimConstraint TimesNumTerm {} x = x +introSupportedPrimConstraint AbsNumTerm {} x = x +introSupportedPrimConstraint SignumNumTerm {} x = x +introSupportedPrimConstraint LTNumTerm {} x = x +introSupportedPrimConstraint LENumTerm {} x = x +introSupportedPrimConstraint AndBitsTerm {} x = x +introSupportedPrimConstraint OrBitsTerm {} x = x +introSupportedPrimConstraint XorBitsTerm {} x = x +introSupportedPrimConstraint ComplementBitsTerm {} x = x +introSupportedPrimConstraint ShiftBitsTerm {} x = x +introSupportedPrimConstraint RotateBitsTerm {} x = x +introSupportedPrimConstraint BVConcatTerm {} x = x +introSupportedPrimConstraint BVSelectTerm {} x = x +introSupportedPrimConstraint BVExtendTerm {} x = x +introSupportedPrimConstraint TabularFunApplyTerm {} x = x +introSupportedPrimConstraint GeneralFunApplyTerm {} x = x +introSupportedPrimConstraint DivIntegerTerm {} x = x +introSupportedPrimConstraint ModIntegerTerm {} x = x +{-# INLINE introSupportedPrimConstraint #-} + +extractSymbolicsSomeTerm :: SomeTerm -> S.HashSet SomeTypedSymbol +extractSymbolicsSomeTerm t1 = evalState (gocached t1) M.empty + where + gocached :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) + gocached t = do + v <- gets (M.lookup t) + case v of + Just x -> return x + Nothing -> do + res <- go t + st <- get + put $ M.insert t res st + return res + go :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) + go (SomeTerm ConTerm {}) = return S.empty + go (SomeTerm (SymTerm _ (sym :: TypedSymbol a))) = return $ S.singleton $ SomeTypedSymbol (R.typeRep @a) sym + go (SomeTerm (UnaryTerm _ _ arg)) = goUnary arg + go (SomeTerm (BinaryTerm _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (TernaryTerm _ _ arg1 arg2 arg3)) = goTernary arg1 arg2 arg3 + go (SomeTerm (NotTerm _ arg)) = goUnary arg + go (SomeTerm (OrTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AndTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (EqvTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (ITETerm _ cond arg1 arg2)) = goTernary cond arg1 arg2 + go (SomeTerm (AddNumTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (UMinusNumTerm _ arg)) = goUnary arg + go (SomeTerm (TimesNumTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AbsNumTerm _ arg)) = goUnary arg + go (SomeTerm (SignumNumTerm _ arg)) = goUnary arg + go (SomeTerm (LTNumTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (LENumTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AndBitsTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (OrBitsTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (XorBitsTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary arg + go (SomeTerm (ShiftBitsTerm _ arg _)) = goUnary arg + go (SomeTerm (RotateBitsTerm _ arg _)) = goUnary arg + go (SomeTerm (BVConcatTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (BVSelectTerm _ _ _ arg)) = goUnary arg + go (SomeTerm (BVExtendTerm _ _ _ arg)) = goUnary arg + go (SomeTerm (TabularFunApplyTerm _ func arg)) = goBinary func arg + go (SomeTerm (GeneralFunApplyTerm _ func arg)) = goBinary func arg + go (SomeTerm (DivIntegerTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (ModIntegerTerm _ arg1 arg2)) = goBinary arg1 arg2 + goUnary arg = gocached (SomeTerm arg) + goBinary arg1 arg2 = do + r1 <- gocached (SomeTerm arg1) + r2 <- gocached (SomeTerm arg2) + return $ r1 <> r2 + goTernary arg1 arg2 arg3 = do + r1 <- gocached (SomeTerm arg1) + r2 <- gocached (SomeTerm arg2) + r3 <- gocached (SomeTerm arg3) + return $ r1 <> r2 <> r3 +{-# INLINEABLE extractSymbolicsSomeTerm #-} + +extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol +extractSymbolicsTerm t = extractSymbolicsSomeTerm (SomeTerm t) +{-# INLINE extractSymbolicsTerm #-} + +castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) +castTerm t@ConTerm {} = cast t +castTerm t@SymTerm {} = cast t +castTerm t@UnaryTerm {} = cast t +castTerm t@BinaryTerm {} = cast t +castTerm t@TernaryTerm {} = cast t +castTerm t@NotTerm {} = cast t +castTerm t@OrTerm {} = cast t +castTerm t@AndTerm {} = cast t +castTerm t@EqvTerm {} = cast t +castTerm t@ITETerm {} = cast t +castTerm t@AddNumTerm {} = cast t +castTerm t@UMinusNumTerm {} = cast t +castTerm t@TimesNumTerm {} = cast t +castTerm t@AbsNumTerm {} = cast t +castTerm t@SignumNumTerm {} = cast t +castTerm t@LTNumTerm {} = cast t +castTerm t@LENumTerm {} = cast t +castTerm t@AndBitsTerm {} = cast t +castTerm t@OrBitsTerm {} = cast t +castTerm t@XorBitsTerm {} = cast t +castTerm t@ComplementBitsTerm {} = cast t +castTerm t@ShiftBitsTerm {} = cast t +castTerm t@RotateBitsTerm {} = cast t +castTerm t@BVConcatTerm {} = cast t +castTerm t@BVSelectTerm {} = cast t +castTerm t@BVExtendTerm {} = cast t +castTerm t@TabularFunApplyTerm {} = cast t +castTerm t@GeneralFunApplyTerm {} = cast t +castTerm t@DivIntegerTerm {} = cast t +castTerm t@ModIntegerTerm {} = cast t +{-# INLINE castTerm #-} + +pformat :: forall t. (SupportedPrim t) => Term t -> String +pformat (ConTerm _ t) = pformatCon t +pformat (SymTerm _ sym) = pformatSym sym +pformat (UnaryTerm _ tag arg1) = pformatUnary tag arg1 +pformat (BinaryTerm _ tag arg1 arg2) = pformatBinary tag arg1 arg2 +pformat (TernaryTerm _ tag arg1 arg2 arg3) = pformatTernary tag arg1 arg2 arg3 +pformat (NotTerm _ arg) = "(! " ++ pformat arg ++ ")" +pformat (OrTerm _ arg1 arg2) = "(|| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AndTerm _ arg1 arg2) = "(&& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (EqvTerm _ arg1 arg2) = "(= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (ITETerm _ cond arg1 arg2) = "(ite " ++ pformat cond ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AddNumTerm _ arg1 arg2) = "(+ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (UMinusNumTerm _ arg) = "(- " ++ pformat arg ++ ")" +pformat (TimesNumTerm _ arg1 arg2) = "(* " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AbsNumTerm _ arg) = "(abs " ++ pformat arg ++ ")" +pformat (SignumNumTerm _ arg) = "(signum " ++ pformat arg ++ ")" +pformat (LTNumTerm _ arg1 arg2) = "(< " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (LENumTerm _ arg1 arg2) = "(<= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AndBitsTerm _ arg1 arg2) = "(& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (OrBitsTerm _ arg1 arg2) = "(| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (XorBitsTerm _ arg1 arg2) = "(^ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (ComplementBitsTerm _ arg) = "(~ " ++ pformat arg ++ ")" +pformat (ShiftBitsTerm _ arg n) = "(shift " ++ pformat arg ++ " " ++ show n ++ ")" +pformat (RotateBitsTerm _ arg n) = "(rotate " ++ pformat arg ++ " " ++ show n ++ ")" +pformat (BVConcatTerm _ arg1 arg2) = "(bvconcat " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (BVSelectTerm _ ix w arg) = "(bvselect " ++ show ix ++ " " ++ show w ++ " " ++ pformat arg ++ ")" +pformat (BVExtendTerm _ signed n arg) = + (if signed then "(bvsext " else "(bvzext") ++ show n ++ " " ++ pformat arg ++ ")" +pformat (TabularFunApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")" +pformat (GeneralFunApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")" +pformat (DivIntegerTerm _ arg1 arg2) = "(div " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (ModIntegerTerm _ arg1 arg2) = "(mod " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +{-# INLINE pformat #-} + +termsSize :: [Term a] -> Int +termsSize terms = S.size $ execState (traverse go terms) S.empty + where + exists t = gets (S.member (SomeTerm t)) + add t = modify' (S.insert (SomeTerm t)) + go :: forall b. Term b -> State (S.HashSet SomeTerm) () + go t@ConTerm {} = add t + go t@SymTerm {} = add t + go t@(UnaryTerm _ _ arg) = goUnary t arg + go t@(BinaryTerm _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(TernaryTerm _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3 + go t@(NotTerm _ arg) = goUnary t arg + go t@(OrTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AndTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(EqvTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ITETerm _ cond arg1 arg2) = goTernary t cond arg1 arg2 + go t@(AddNumTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(UMinusNumTerm _ arg) = goUnary t arg + go t@(TimesNumTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AbsNumTerm _ arg) = goUnary t arg + go t@(SignumNumTerm _ arg) = goUnary t arg + go t@(LTNumTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(LENumTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AndBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(OrBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(XorBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ComplementBitsTerm _ arg) = goUnary t arg + go t@(ShiftBitsTerm _ arg _) = goUnary t arg + go t@(RotateBitsTerm _ arg _) = goUnary t arg + go t@(BVConcatTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(BVSelectTerm _ _ _ arg) = goUnary t arg + go t@(BVExtendTerm _ _ _ arg) = goUnary t arg + go t@(TabularFunApplyTerm _ func arg) = goBinary t func arg + go t@(GeneralFunApplyTerm _ func arg) = goBinary t func arg + go t@(DivIntegerTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ModIntegerTerm _ arg1 arg2) = goBinary t arg1 arg2 + goUnary :: forall a b. (SupportedPrim a) => Term a -> Term b -> State (S.HashSet SomeTerm) () + goUnary t arg = do + b <- exists t + if b + then return () + else do + add t + go arg + goBinary :: + forall a b c. + (SupportedPrim a, SupportedPrim b) => + Term a -> + Term b -> + Term c -> + State (S.HashSet SomeTerm) () + goBinary t arg1 arg2 = do + b <- exists t + if b + then return () + else do + add t + go arg1 + go arg2 + goTernary :: + forall a b c d. + (SupportedPrim a, SupportedPrim b, SupportedPrim c) => + Term a -> + Term b -> + Term c -> + Term d -> + State (S.HashSet SomeTerm) () + goTernary t arg1 arg2 arg3 = do + b <- exists t + if b + then return () + else do + add t + go arg1 + go arg2 + go arg3 +{-# INLINEABLE termsSize #-} + +termSize :: Term a -> Int +termSize term = termsSize [term] +{-# INLINE termSize #-} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils + ( identity, + identityWithTypeRep, + introSupportedPrimConstraint, + extractSymbolicsTerm, + castTerm, + pformat, + termSize, + termsSize, + ) +where + +import Data.HashSet as S +import Data.Interned +import Data.Typeable +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + +identity :: Term t -> Id +identityWithTypeRep :: forall t. Term t -> (TypeRep, Id) +introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a +extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol +castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) +pformat :: forall t. (SupportedPrim t) => Term t -> String +termsSize :: [Term a] -> Int +termSize :: Term a -> Int diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Model.hs b/src/Grisette/IR/SymPrim/Data/Prim/Model.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/Model.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.Model +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.Model + ( SymbolSet (..), + Model (..), + ModelValuePair (..), + equation, + evaluateTerm, + ) +where + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Hashable +import Data.List +import Data.Proxy +import GHC.Generics +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.ModelOps +import Grisette.Core.Data.MemoUtils +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.ModelValue +import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +import Type.Reflection +import Unsafe.Coerce + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> :set -XFlexibleContexts + +-- | Symbolic constant set. +newtype SymbolSet = SymbolSet {unSymbolSet :: S.HashSet SomeTypedSymbol} + deriving (Eq, Generic, Hashable, Semigroup, Monoid) + +instance Show SymbolSet where + showsPrec prec (SymbolSet s) = showParen (prec >= 10) $ \x -> + "SymbolSet {" + ++ go0 (sort $ show <$> S.toList s) + ++ "}" + ++ x + where + go0 [] = "" + go0 [x] = x + go0 (x : xs) = x ++ ", " ++ go0 xs + +-- | Model returned by the solver. +newtype Model = Model {unModel :: M.HashMap SomeTypedSymbol ModelValue} deriving (Eq, Generic, Hashable) + +instance Show Model where + showsPrec prec (Model m) = showParen (prec >= 10) $ \x -> + "Model {" + ++ go0 (sortOn (\(x, _) -> show x) $ M.toList m) + ++ "}" + ++ x + where + go0 [] = "" + go0 [(SomeTypedSymbol _ s, v)] = showUntyped s ++ " -> " ++ show v + go0 ((SomeTypedSymbol _ s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs + +equation :: TypedSymbol a -> Model -> Maybe (Term Bool) +equation tsym m = withSymbolSupported tsym $ + case valueOf tsym m of + Just v -> Just $ pevalEqvTerm (symTerm tsym) (conTerm v) + Nothing -> Nothing + +instance SymbolSetOps SymbolSet TypedSymbol where + emptySet = SymbolSet S.empty + isEmptySet (SymbolSet s) = S.null s + containsSymbol s = + S.member (someTypedSymbol s) . unSymbolSet + insertSymbol s = SymbolSet . S.insert (someTypedSymbol s) . unSymbolSet + intersectionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.intersection s1 s2 + unionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.union s1 s2 + differenceSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.difference s1 s2 + +instance SymbolSetRep (TypedSymbol t) SymbolSet TypedSymbol where + buildSymbolSet sym = insertSymbol sym emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2) = + insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3) = + insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4) = + insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5) = + insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e, + TypedSymbol f + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6) = + insertSymbol sym6 + . insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e, + TypedSymbol f, + TypedSymbol g + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7) = + insertSymbol sym7 + . insertSymbol sym6 + . insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e, + TypedSymbol f, + TypedSymbol g, + TypedSymbol h + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7, sym8) = + insertSymbol sym8 + . insertSymbol sym7 + . insertSymbol sym6 + . insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance ExtractSymbolics SymbolSet where + extractSymbolics = id + +instance ModelOps Model SymbolSet TypedSymbol where + emptyModel = Model M.empty + isEmptyModel (Model m) = M.null m + valueOf :: forall t. TypedSymbol t -> Model -> Maybe t + valueOf sym (Model m) = + withSymbolSupported sym $ + (unsafeFromModelValue @t) + <$> M.lookup (someTypedSymbol sym) m + exceptFor (SymbolSet s) (Model m) = Model $ S.foldl' (flip M.delete) m s + restrictTo (SymbolSet s) (Model m) = + Model $ + S.foldl' + ( \acc sym -> case M.lookup sym m of + Just v -> M.insert sym v acc + Nothing -> acc + ) + M.empty + s + extendTo (SymbolSet s) (Model m) = + Model $ + S.foldl' + ( \acc sym@(SomeTypedSymbol _ (tsym :: TypedSymbol t)) -> case M.lookup sym acc of + Just _ -> acc + Nothing -> withSymbolSupported tsym $ M.insert sym (defaultValueDynamic (Proxy @t)) acc + ) + m + s + insertValue sym (v :: t) (Model m) = + withSymbolSupported sym $ + Model $ + M.insert (someTypedSymbol sym) (toModelValue v) m + +evaluateSomeTerm :: Bool -> Model -> SomeTerm -> SomeTerm +evaluateSomeTerm fillDefault (Model ma) = gomemo + where + gomemo = htmemo go + gotyped :: (SupportedPrim a) => Term a -> Term a + gotyped a = case gomemo (SomeTerm a) of + SomeTerm v -> unsafeCoerce v + go c@(SomeTerm ConTerm {}) = c + go c@(SomeTerm ((SymTerm _ sym) :: Term a)) = + case M.lookup (someTypedSymbol sym) ma of + Nothing -> if fillDefault then SomeTerm $ conTerm (defaultValue @a) else c + Just dy -> SomeTerm $ conTerm (unsafeFromModelValue @a dy) + go (SomeTerm (UnaryTerm _ tag (arg :: Term a))) = goUnary (partialEvalUnary tag) arg + go (SomeTerm (BinaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2))) = + goBinary (partialEvalBinary tag) arg1 arg2 + go (SomeTerm (TernaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2) (arg3 :: Term a3))) = do + goTernary (partialEvalTernary tag) arg1 arg2 arg3 + go (SomeTerm (NotTerm _ arg)) = goUnary pevalNotTerm arg + go (SomeTerm (OrTerm _ arg1 arg2)) = + goBinary pevalOrTerm arg1 arg2 + go (SomeTerm (AndTerm _ arg1 arg2)) = + goBinary pevalAndTerm arg1 arg2 + go (SomeTerm (EqvTerm _ arg1 arg2)) = + goBinary pevalEqvTerm arg1 arg2 + go (SomeTerm (ITETerm _ cond arg1 arg2)) = + goTernary pevalITETerm cond arg1 arg2 + go (SomeTerm (AddNumTerm _ arg1 arg2)) = + goBinary pevalAddNumTerm arg1 arg2 + go (SomeTerm (UMinusNumTerm _ arg)) = goUnary pevalUMinusNumTerm arg + go (SomeTerm (TimesNumTerm _ arg1 arg2)) = + goBinary pevalTimesNumTerm arg1 arg2 + go (SomeTerm (AbsNumTerm _ arg)) = goUnary pevalAbsNumTerm arg + go (SomeTerm (SignumNumTerm _ arg)) = goUnary pevalSignumNumTerm arg + go (SomeTerm (LTNumTerm _ arg1 arg2)) = + goBinary pevalLtNumTerm arg1 arg2 + go (SomeTerm (LENumTerm _ arg1 arg2)) = + goBinary pevalLeNumTerm arg1 arg2 + go (SomeTerm (AndBitsTerm _ arg1 arg2)) = + goBinary pevalAndBitsTerm arg1 arg2 + go (SomeTerm (OrBitsTerm _ arg1 arg2)) = + goBinary pevalOrBitsTerm arg1 arg2 + go (SomeTerm (XorBitsTerm _ arg1 arg2)) = + goBinary pevalXorBitsTerm arg1 arg2 + go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary pevalComplementBitsTerm arg + go (SomeTerm (ShiftBitsTerm _ arg n)) = + goUnary (`pevalShiftBitsTerm` n) arg + go (SomeTerm (RotateBitsTerm _ arg n)) = + goUnary (`pevalRotateBitsTerm` n) arg + go (SomeTerm (BVConcatTerm _ arg1 arg2)) = + goBinary pevalBVConcatTerm arg1 arg2 + go (SomeTerm (BVSelectTerm _ ix w arg)) = + goUnary (pevalBVSelectTerm ix w) arg + go (SomeTerm (BVExtendTerm _ n signed arg)) = + goUnary (pevalBVExtendTerm n signed) arg + go (SomeTerm (TabularFunApplyTerm _ f arg)) = + goBinary pevalTabularFunApplyTerm f arg + go (SomeTerm (GeneralFunApplyTerm _ f arg)) = + goBinary pevalGeneralFunApplyTerm f arg + go (SomeTerm (DivIntegerTerm _ arg1 arg2)) = + goBinary pevalDivIntegerTerm arg1 arg2 + go (SomeTerm (ModIntegerTerm _ arg1 arg2)) = + goBinary pevalModIntegerTerm arg1 arg2 + goUnary :: (SupportedPrim a, SupportedPrim b) => (Term a -> Term b) -> Term a -> SomeTerm + goUnary f a = SomeTerm $ f (gotyped a) + goBinary :: + (SupportedPrim a, SupportedPrim b, SupportedPrim c) => + (Term a -> Term b -> Term c) -> + Term a -> + Term b -> + SomeTerm + goBinary f a b = SomeTerm $ f (gotyped a) (gotyped b) + goTernary :: + (SupportedPrim a, SupportedPrim b, SupportedPrim c, SupportedPrim d) => + (Term a -> Term b -> Term c -> Term d) -> + Term a -> + Term b -> + Term c -> + SomeTerm + goTernary f a b c = SomeTerm $ f (gotyped a) (gotyped b) (gotyped c) + +evaluateTerm :: forall a. (SupportedPrim a) => Bool -> Model -> Term a -> Term a +evaluateTerm fillDefault m t = case evaluateSomeTerm fillDefault m $ SomeTerm t of + SomeTerm (t1 :: Term b) -> unsafeCoerce @(Term b) @(Term a) t1 + +-- | +-- A type used for building a model by hand. +-- +-- >>> buildModel ("x" ::= (1 :: Integer), "y" ::= True) :: Model +-- Model {x -> 1 :: Integer, y -> True :: Bool} +data ModelValuePair t = (TypedSymbol t) ::= t deriving (Show) + +instance ModelRep (ModelValuePair t) Model SymbolSet TypedSymbol where + buildModel (sym ::= val) = insertValue sym val emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2 + ) = + insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3 + ) = + insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4 + ) = + insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5 + ) = + insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e, + ModelValuePair f + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5, + sym6 ::= val6 + ) = + insertValue sym6 val6 + . insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e, + ModelValuePair f, + ModelValuePair g + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5, + sym6 ::= val6, + sym7 ::= val7 + ) = + insertValue sym7 val7 + . insertValue sym6 val6 + . insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e, + ModelValuePair f, + ModelValuePair g, + ModelValuePair h + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5, + sym6 ::= val6, + sym7 ::= val7, + sym8 ::= val8 + ) = + insertValue sym8 val8 + . insertValue sym7 val7 + . insertValue sym6 val6 + . insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Model.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/Model.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/Model.hs-boot @@ -0,0 +1,10 @@ +module Grisette.IR.SymPrim.Data.Prim.Model where + +import qualified Data.HashSet as S +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + +newtype SymbolSet = SymbolSet {unSymbolSet :: S.HashSet SomeTypedSymbol} + +instance Monoid SymbolSet + +instance Semigroup SymbolSet diff --git a/src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs b/src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.ModelValue +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.ModelValue + ( ModelValue (..), + toModelValue, + unsafeFromModelValue, + ) +where + +import Data.Hashable +import Type.Reflection + +data ModelValue where + ModelValue :: forall v. (Show v, Eq v, Hashable v) => TypeRep v -> v -> ModelValue + +instance Show ModelValue where + show (ModelValue t v) = show v ++ " :: " ++ show t + +instance Eq ModelValue where + (ModelValue t1 v1) == (ModelValue t2 v2) = + case eqTypeRep t1 t2 of + Just HRefl -> v1 == v2 + _ -> False + +instance Hashable ModelValue where + s `hashWithSalt` (ModelValue t v) = s `hashWithSalt` t `hashWithSalt` v + +unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a +unsafeFromModelValue (ModelValue t v) = case eqTypeRep t (typeRep @a) of + Just HRefl -> v + _ -> error $ "Bad model value type, expected type: " ++ show (typeRep @a) ++ ", but got: " ++ show t + +toModelValue :: forall a. (Show a, Eq a, Hashable a, Typeable a) => a -> ModelValue +toModelValue = ModelValue (typeRep @a) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.BV + ( pevalBVConcatTerm, + pevalBVSelectTerm, + pevalBVExtendTerm, + pevalBVZeroExtendTerm, + pevalBVSignExtendTerm, + ) +where + +import GHC.TypeNats +import Grisette.Core.Data.Class.BitVector +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold + +-- select +pevalBVSelectTerm :: + forall bv a ix w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat w, + KnownNat ix, + BVSelect (bv a) ix w (bv w) + ) => + proxy ix -> + proxy w -> + Term (bv a) -> + Term (bv w) +pevalBVSelectTerm ix w = unaryUnfoldOnce (doPevalBVSelectTerm ix w) (bvselectTerm ix w) + +doPevalBVSelectTerm :: + forall bv a ix w proxy. + ( SupportedPrim (bv a), + SupportedPrim (bv w), + KnownNat a, + KnownNat w, + KnownNat ix, + BVSelect (bv a) ix w (bv w) + ) => + proxy ix -> + proxy w -> + Term (bv a) -> + Maybe (Term (bv w)) +doPevalBVSelectTerm ix w (ConTerm _ b) = Just $ conTerm $ bvselect ix w b +doPevalBVSelectTerm _ _ _ = Nothing + +-- ext +pevalBVZeroExtendTerm :: + forall proxy a n b bv. + ( KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b), + SupportedPrim (bv a), + SupportedPrim (bv b) + ) => + proxy n -> + Term (bv a) -> + Term (bv b) +pevalBVZeroExtendTerm = pevalBVExtendTerm False + +pevalBVSignExtendTerm :: + forall proxy a n b bv. + ( KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b), + SupportedPrim (bv a), + SupportedPrim (bv b) + ) => + proxy n -> + Term (bv a) -> + Term (bv b) +pevalBVSignExtendTerm = pevalBVExtendTerm True + +pevalBVExtendTerm :: + forall proxy a n b bv. + ( KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b), + SupportedPrim (bv a), + SupportedPrim (bv b) + ) => + Bool -> + proxy n -> + Term (bv a) -> + Term (bv b) +pevalBVExtendTerm signed p = unaryUnfoldOnce (doPevalBVExtendTerm signed p) (bvextendTerm signed p) + +doPevalBVExtendTerm :: + forall proxy a n b bv. + ( KnownNat a, + KnownNat b, + KnownNat n, + BVExtend (bv a) n (bv b), + SupportedPrim (bv a), + SupportedPrim (bv b) + ) => + Bool -> + proxy n -> + Term (bv a) -> + Maybe (Term (bv b)) +doPevalBVExtendTerm signed p (ConTerm _ b) = Just $ conTerm $ if signed then bvsignExtend p b else bvzeroExtend p b +doPevalBVExtendTerm _ _ _ = Nothing + +pevalBVConcatTerm :: + ( SupportedPrim (s w), + SupportedPrim (s w'), + SupportedPrim (s w''), + KnownNat w, + KnownNat w', + KnownNat w'', + BVConcat (s w) (s w') (s w'') + ) => + Term (s w) -> + Term (s w') -> + Term (s w'') +pevalBVConcatTerm = binaryUnfoldOnce doPevalBVConcatTerm bvconcatTerm + +doPevalBVConcatTerm :: + ( SupportedPrim (s w), + SupportedPrim (s w'), + SupportedPrim (s w''), + KnownNat w, + KnownNat w', + KnownNat w'', + BVConcat (s w) (s w') (s w'') + ) => + Term (s w) -> + Term (s w') -> + Maybe (Term (s w'')) +doPevalBVConcatTerm (ConTerm _ v) (ConTerm _ v') = Just $ conTerm $ bvconcat v v' +doPevalBVConcatTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits + ( pattern BitsConTerm, + pevalAndBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm, + pevalComplementBitsTerm, + pevalShiftBitsTerm, + pevalRotateBitsTerm, + ) +where + +import Data.Bits +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold + +bitsConTermView :: (Bits b, Typeable b) => Term a -> Maybe b +bitsConTermView (ConTerm _ b) = cast b +bitsConTermView _ = Nothing + +pattern BitsConTerm :: forall b a. (Bits b, Typeable b) => b -> Term a +pattern BitsConTerm b <- (bitsConTermView -> Just b) + +-- bitand +pevalAndBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a +pevalAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm + +doPevalAndBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalAndBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .&. b) +doPevalAndBitsTerm (ConTerm _ a) b + | a == zeroBits = Just $ conTerm zeroBits + | a == complement zeroBits = Just b +doPevalAndBitsTerm a (ConTerm _ b) + | b == zeroBits = Just $ conTerm zeroBits + | b == complement zeroBits = Just a +doPevalAndBitsTerm a b | a == b = Just a +doPevalAndBitsTerm _ _ = Nothing + +-- bitor +pevalOrBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a +pevalOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm + +doPevalOrBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalOrBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .|. b) +doPevalOrBitsTerm (ConTerm _ a) b + | a == zeroBits = Just b + | a == complement zeroBits = Just $ conTerm $ complement zeroBits +doPevalOrBitsTerm a (ConTerm _ b) + | b == zeroBits = Just a + | b == complement zeroBits = Just $ conTerm $ complement zeroBits +doPevalOrBitsTerm a b | a == b = Just a +doPevalOrBitsTerm _ _ = Nothing + +-- bitxor +pevalXorBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a +pevalXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm + +doPevalXorBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalXorBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a `xor` b) +doPevalXorBitsTerm (ConTerm _ a) b + | a == zeroBits = Just b + | a == complement zeroBits = Just $ pevalComplementBitsTerm b +doPevalXorBitsTerm a (ConTerm _ b) + | b == zeroBits = Just a + | b == complement zeroBits = Just $ pevalComplementBitsTerm a +doPevalXorBitsTerm a b | a == b = Just $ conTerm zeroBits +doPevalXorBitsTerm (ComplementBitsTerm _ i) (ComplementBitsTerm _ j) = Just $ pevalXorBitsTerm i j +doPevalXorBitsTerm (ComplementBitsTerm _ i) j = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j +doPevalXorBitsTerm i (ComplementBitsTerm _ j) = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j +doPevalXorBitsTerm _ _ = Nothing + +-- complement +pevalComplementBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a +pevalComplementBitsTerm = unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm + +doPevalComplementBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Maybe (Term a) +doPevalComplementBitsTerm (ConTerm _ a) = Just $ conTerm $ complement a +doPevalComplementBitsTerm (ComplementBitsTerm _ a) = Just a +doPevalComplementBitsTerm _ = Nothing + +-- shift +pevalShiftBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Int -> Term a +pevalShiftBitsTerm t n = unaryUnfoldOnce (`doPevalShiftBitsTerm` n) (`shiftBitsTerm` n) t + +doPevalShiftBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Int -> Maybe (Term a) +doPevalShiftBitsTerm (ConTerm _ a) n = Just $ conTerm $ shift a n +doPevalShiftBitsTerm x 0 = Just x +doPevalShiftBitsTerm _ a + | case bitSizeMaybe (zeroBits :: a) of + Just b -> a >= b + Nothing -> False = + Just $ conTerm zeroBits +doPevalShiftBitsTerm (ShiftBitsTerm _ x n) n1 + | (n >= 0 && n1 >= 0) || (n <= 0 && n1 <= 0) = Just $ shiftBitsTerm x (n + n1) +doPevalShiftBitsTerm _ _ = Nothing + +-- rotate +pevalRotateBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Int -> Term a +pevalRotateBitsTerm t n = unaryUnfoldOnce (`doPevalRotateBitsTerm` n) (`rotateBitsTerm` n) t + +doPevalRotateBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Int -> Maybe (Term a) +doPevalRotateBitsTerm (ConTerm _ a) n = Just $ conTerm $ rotate a n +doPevalRotateBitsTerm x 0 = Just x +doPevalRotateBitsTerm x a + | case bsize of + Just s -> s /= 0 && (a >= s || a < 0) + Nothing -> False = do + cbsize <- bsize + if a >= cbsize + then Just $ pevalRotateBitsTerm x (a - cbsize) + else Just $ pevalRotateBitsTerm x (a + cbsize) + where + bsize = bitSizeMaybe (zeroBits :: a) +doPevalRotateBitsTerm (RotateBitsTerm _ x n) n1 = Just $ rotateBitsTerm x (n + n1) +doPevalRotateBitsTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool + ( trueTerm, + falseTerm, + pattern BoolConTerm, + pattern TrueTerm, + pattern FalseTerm, + pattern BoolTerm, + pevalNotTerm, + pevalEqvTerm, + pevalNotEqvTerm, + pevalOrTerm, + pevalAndTerm, + pevalITETerm, + pevalImplyTerm, + pevalXorTerm, + ) +where + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.Prim.Utils +import Unsafe.Coerce + +trueTerm :: Term Bool +trueTerm = conTerm True +{-# INLINE trueTerm #-} + +falseTerm :: Term Bool +falseTerm = conTerm False +{-# INLINE falseTerm #-} + +boolConTermView :: forall a. Term a -> Maybe Bool +boolConTermView (ConTerm _ b) = cast b +boolConTermView _ = Nothing +{-# INLINE boolConTermView #-} + +pattern BoolConTerm :: Bool -> Term a +pattern BoolConTerm b <- (boolConTermView -> Just b) + +pattern TrueTerm :: Term a +pattern TrueTerm <- BoolConTerm True + +pattern FalseTerm :: Term a +pattern FalseTerm <- BoolConTerm False + +pattern BoolTerm :: Term Bool -> Term a +pattern BoolTerm b <- (castTerm -> Just b) + +-- Not +pevalNotTerm :: Term Bool -> Term Bool +pevalNotTerm (NotTerm _ tm) = tm +pevalNotTerm (ConTerm _ a) = if a then falseTerm else trueTerm +pevalNotTerm (OrTerm _ (NotTerm _ n1) n2) = pevalAndTerm n1 (pevalNotTerm n2) +pevalNotTerm (OrTerm _ n1 (NotTerm _ n2)) = pevalAndTerm (pevalNotTerm n1) n2 +pevalNotTerm (AndTerm _ (NotTerm _ n1) n2) = pevalOrTerm n1 (pevalNotTerm n2) +pevalNotTerm (AndTerm _ n1 (NotTerm _ n2)) = pevalOrTerm (pevalNotTerm n1) n2 +pevalNotTerm tm = notTerm tm +{-# INLINEABLE pevalNotTerm #-} + +-- Eqv +pevalEqvTerm :: forall a. (SupportedPrim a) => Term a -> Term a -> Term Bool +pevalEqvTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r +pevalEqvTerm l@ConTerm {} r = pevalEqvTerm r l +pevalEqvTerm l (BoolConTerm rv) = if rv then unsafeCoerce l else pevalNotTerm $ unsafeCoerce l +pevalEqvTerm (NotTerm _ lv) r + | lv == unsafeCoerce r = falseTerm +pevalEqvTerm l (NotTerm _ rv) + | unsafeCoerce l == rv = falseTerm +{- +pevalBinary _ (ConTerm l) (ConTerm r) = + if l == r then trueTerm else falseTerm + -} +pevalEqvTerm + ( AddNumTerm + _ + (ConTerm _ c :: Term a) + (Dyn (v :: Term a)) + ) + (Dyn (ConTerm _ c2 :: Term a)) = + pevalEqvTerm v (conTerm $ c2 - c) +pevalEqvTerm + (Dyn (ConTerm _ c2 :: Term a)) + ( AddNumTerm + _ + (Dyn (ConTerm _ c :: Term a)) + (Dyn (v :: Term a)) + ) = + pevalEqvTerm v (conTerm $ c2 - c) +pevalEqvTerm l (ITETerm _ c t f) + | l == t = pevalOrTerm c (pevalEqvTerm l f) + | l == f = pevalOrTerm (pevalNotTerm c) (pevalEqvTerm l t) +pevalEqvTerm (ITETerm _ c t f) r + | t == r = pevalOrTerm c (pevalEqvTerm f r) + | f == r = pevalOrTerm (pevalNotTerm c) (pevalEqvTerm t r) +pevalEqvTerm l r + | l == r = trueTerm + | otherwise = eqvTerm l r +{-# INLINEABLE pevalEqvTerm #-} + +pevalNotEqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool +pevalNotEqvTerm l r = pevalNotTerm $ pevalEqvTerm l r +{-# INLINE pevalNotEqvTerm #-} + +pevalImpliesTerm :: Term Bool -> Term Bool -> Bool +pevalImpliesTerm (ConTerm _ False) _ = True +pevalImpliesTerm _ (ConTerm _ True) = True +pevalImpliesTerm + (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) + | e1 == e2 && ec1 /= ec2 = True +pevalImpliesTerm a b + | a == b = True + | otherwise = False +{-# INLINE pevalImpliesTerm #-} + +orEqFirst :: Term Bool -> Term Bool -> Bool +orEqFirst _ (ConTerm _ False) = True +orEqFirst + (NotTerm _ (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) + (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) + | e1 == e2 && ec1 /= ec2 = True +orEqFirst x y + | x == y = True + | otherwise = False +{-# INLINE orEqFirst #-} + +orEqTrue :: Term Bool -> Term Bool -> Bool +orEqTrue (ConTerm _ True) _ = True +orEqTrue _ (ConTerm _ True) = True +-- orEqTrue (NotTerm _ e1) (NotTerm _ e2) = andEqFalse e1 e2 +orEqTrue + (NotTerm _ (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) + (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) + | e1 == e2 && ec1 /= ec2 = True +orEqTrue (NotTerm _ l) r | l == r = True +orEqTrue l (NotTerm _ r) | l == r = True +orEqTrue _ _ = False +{-# INLINE orEqTrue #-} + +andEqFirst :: Term Bool -> Term Bool -> Bool +andEqFirst _ (ConTerm _ True) = True +-- andEqFirst x (NotTerm _ y) = andEqFalse x y +andEqFirst + (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) + | e1 == e2 && ec1 /= ec2 = True +andEqFirst x y + | x == y = True + | otherwise = False +{-# INLINE andEqFirst #-} + +andEqFalse :: Term Bool -> Term Bool -> Bool +andEqFalse (ConTerm _ False) _ = True +andEqFalse _ (ConTerm _ False) = True +-- andEqFalse (NotTerm _ e1) (NotTerm _ e2) = orEqTrue e1 e2 +andEqFalse + (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) + | e1 == e2 && ec1 /= ec2 = True +andEqFalse (NotTerm _ x) y | x == y = True +andEqFalse x (NotTerm _ y) | x == y = True +andEqFalse _ _ = False +{-# INLINE andEqFalse #-} + +-- Or +pevalOrTerm :: Term Bool -> Term Bool -> Term Bool +pevalOrTerm l r + | orEqTrue l r = trueTerm + | orEqFirst l r = l + | orEqFirst r l = r +pevalOrTerm l r@(OrTerm _ r1 r2) + | orEqTrue l r1 = trueTerm + | orEqTrue l r2 = trueTerm + | orEqFirst r1 l = r + | orEqFirst r2 l = r + | orEqFirst l r1 = pevalOrTerm l r2 + | orEqFirst l r2 = pevalOrTerm l r1 +pevalOrTerm l@(OrTerm _ l1 l2) r + | orEqTrue l1 r = trueTerm + | orEqTrue l2 r = trueTerm + | orEqFirst l1 r = l + | orEqFirst l2 r = l + | orEqFirst r l1 = pevalOrTerm l2 r + | orEqFirst r l2 = pevalOrTerm l1 r +pevalOrTerm l (AndTerm _ r1 r2) + | orEqFirst l r1 = l + | orEqFirst l r2 = l + | orEqTrue l r1 = pevalOrTerm l r2 + | orEqTrue l r2 = pevalOrTerm l r1 +pevalOrTerm (AndTerm _ l1 l2) r + | orEqFirst r l1 = r + | orEqFirst r l2 = r + | orEqTrue l1 r = pevalOrTerm l2 r + | orEqTrue l2 r = pevalOrTerm l1 r +pevalOrTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalAndTerm nl nr +pevalOrTerm l r = orTerm l r +{-# INLINEABLE pevalOrTerm #-} + +pevalAndTerm :: Term Bool -> Term Bool -> Term Bool +pevalAndTerm l r + | andEqFalse l r = falseTerm + | andEqFirst l r = l + | andEqFirst r l = r +pevalAndTerm l r@(AndTerm _ r1 r2) + | andEqFalse l r1 = falseTerm + | andEqFalse l r2 = falseTerm + | andEqFirst r1 l = r + | andEqFirst r2 l = r + | andEqFirst l r1 = pevalAndTerm l r2 + | andEqFirst l r2 = pevalAndTerm l r1 +pevalAndTerm l@(AndTerm _ l1 l2) r + | andEqFalse l1 r = falseTerm + | andEqFalse l2 r = falseTerm + | andEqFirst l1 r = l + | andEqFirst l2 r = l + | andEqFirst r l1 = pevalAndTerm l2 r + | andEqFirst r l2 = pevalAndTerm l1 r +pevalAndTerm l (OrTerm _ r1 r2) + | andEqFirst l r1 = l + | andEqFirst l r2 = l + | andEqFalse l r1 = pevalAndTerm l r2 + | andEqFalse l r2 = pevalAndTerm l r1 +pevalAndTerm (OrTerm _ l1 l2) r + | andEqFirst r l1 = r + | andEqFirst r l2 = r + | andEqFalse l1 r = pevalAndTerm l2 r + | andEqFalse l2 r = pevalAndTerm l1 r +pevalAndTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalOrTerm nl nr +pevalAndTerm l r = andTerm l r +{-# INLINEABLE pevalAndTerm #-} + +pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftNot cond nIfTrue ifFalse + | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse -- need test + | otherwise = case nIfTrue of + AndTerm _ nt1 nt2 -> ra + where + ra + | pevalImpliesTerm cond nt1 = Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse + | pevalImpliesTerm cond nt2 = Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt1) || pevalImpliesTerm cond (pevalNotTerm nt2) = + Just $ pevalOrTerm cond ifFalse + | otherwise = Nothing + OrTerm _ nt1 nt2 -> ra + where + ra + | pevalImpliesTerm cond nt1 || pevalImpliesTerm cond nt2 = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt1) = Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt2) = Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse + | otherwise = Nothing + _ -> Nothing + +pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothNot cond nIfTrue nIfFalse = Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse + +pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightNot cond ifTrue nIfFalse + | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue -- need test + | otherwise = Nothing -- need work + +pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalInferImplies cond (NotTerm _ nt1) trueRes falseRes + | cond == nt1 = Just falseRes + | otherwise = case (cond, nt1) of + ( EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b), + EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)) + ) + | e1 == e2 && ec1 /= ec2 -> Just trueRes + _ -> Nothing +pevalInferImplies + (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) + _ + falseRes + | e1 == e2 && ec1 /= ec2 = Just falseRes +pevalInferImplies _ _ _ _ = Nothing + +pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftAnd cond t1 t2 ifFalse + | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2 + | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1 + | cond == t1 = Just $ pevalITETerm cond t2 ifFalse + | cond == t2 = Just $ pevalITETerm cond t1 ifFalse + | otherwise = + msum + [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse), + pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse) + ] + +pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothAnd cond t1 t2 f1 f2 + | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2 + | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1 + | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2 + | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1 + | otherwise = Nothing + +pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightAnd cond ifTrue f1 f2 + | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2 + | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1 + | otherwise = Nothing + +pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftOr cond t1 t2 ifFalse + | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2 + | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1 + | cond == t1 = Just $ pevalOrTerm cond ifFalse + | cond == t2 = Just $ pevalOrTerm cond ifFalse + | otherwise = + msum + [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse), + pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse) + ] + +pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothOr cond t1 t2 f1 f2 + | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2 + | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1 + | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2 + | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1 + | otherwise = Nothing + +pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightOr cond ifTrue f1 f2 + | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2 + | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1 + | otherwise = Nothing + +pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeft cond (AndTerm _ t1 t2) ifFalse = + msum + [ pevalITEBoolLeftAnd cond t1 t2 ifFalse, + case ifFalse of + AndTerm _ f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2 + _ -> Nothing + ] +pevalITEBoolLeft cond (OrTerm _ t1 t2) ifFalse = + msum + [ pevalITEBoolLeftOr cond t1 t2 ifFalse, + case ifFalse of + OrTerm _ f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2 + _ -> Nothing + ] +pevalITEBoolLeft cond (NotTerm _ nIfTrue) ifFalse = + msum + [ pevalITEBoolLeftNot cond nIfTrue ifFalse, + case ifFalse of + NotTerm _ nIfFalse -> + pevalITEBoolBothNot cond nIfTrue nIfFalse + _ -> Nothing + ] +pevalITEBoolLeft _ _ _ = Nothing + +pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolNoLeft cond ifTrue (AndTerm _ f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2 +pevalITEBoolNoLeft cond ifTrue (OrTerm _ f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2 +pevalITEBoolNoLeft cond ifTrue (NotTerm _ nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse +pevalITEBoolNoLeft _ _ _ = Nothing + +pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a) +pevalITEBasic (ConTerm _ True) ifTrue _ = Just ifTrue +pevalITEBasic (ConTerm _ False) _ ifFalse = Just ifFalse +pevalITEBasic (NotTerm _ ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue +pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue +pevalITEBasic (ITETerm _ cc ct cf) (ITETerm _ tc tt tf) (ITETerm _ fc ft ff) -- later + | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff) +pevalITEBasic cond (ITETerm _ tc tt tf) ifFalse -- later + | cond == tc = Just $ pevalITETerm cond tt ifFalse + | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf + | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf +pevalITEBasic cond ifTrue (ITETerm _ fc ft ff) -- later + | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff + | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft + | pevalImpliesTerm fc cond = Just $ pevalITETerm cond ifTrue ff +pevalITEBasic _ _ _ = Nothing + +pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBasic cond ifTrue ifFalse + | cond == ifTrue = Just $ pevalOrTerm cond ifFalse + | cond == ifFalse = Just $ pevalAndTerm cond ifTrue +pevalITEBoolBasic cond (ConTerm _ v) ifFalse + | v = Just $ pevalOrTerm cond ifFalse + | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse +pevalITEBoolBasic cond ifTrue (ConTerm _ v) + | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue + | otherwise = Just $ pevalAndTerm cond ifTrue +pevalITEBoolBasic _ _ _ = Nothing + +pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBool cond ifTrue ifFalse = + msum + [ pevalITEBasic cond ifTrue ifFalse, + pevalITEBoolBasic cond ifTrue ifFalse, + pevalITEBoolLeft cond ifTrue ifFalse, + pevalITEBoolNoLeft cond ifTrue ifFalse + ] + +pevalITETerm :: forall a. (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a +pevalITETerm cond ifTrue ifFalse = fromMaybe (iteTerm cond ifTrue ifFalse) $ + case eqT @a @Bool of + Nothing -> pevalITEBasic cond ifTrue ifFalse + Just Refl -> pevalITEBool cond ifTrue ifFalse + +pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool +pevalImplyTerm l = pevalOrTerm (pevalNotTerm l) + +pevalXorTerm :: Term Bool -> Term Bool -> Term Bool +pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r)) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun (pevalGeneralFunApplyTerm) where + +import Grisette.Core.Data.Class.Function +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution +import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval + +pevalGeneralFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b +pevalGeneralFunApplyTerm = totalize2 doPevalGeneralFunApplyTerm generalFunApplyTerm + +doPevalGeneralFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Maybe (Term b) +doPevalGeneralFunApplyTerm (ConTerm _ (GeneralFun arg tm)) v = Just $ substTerm arg v tm +doPevalGeneralFunApplyTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integer.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integer.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer + ( pevalDivIntegerTerm, + pevalModIntegerTerm, + ) +where + +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold + +-- div +pevalDivIntegerTerm :: Term Integer -> Term Integer -> Term Integer +pevalDivIntegerTerm = binaryUnfoldOnce doPevalDivIntegerTerm divIntegerTerm + +doPevalDivIntegerTerm :: Term Integer -> Term Integer -> Maybe (Term Integer) +doPevalDivIntegerTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `div` b +doPevalDivIntegerTerm a (ConTerm _ 1) = Just a +doPevalDivIntegerTerm _ _ = Nothing + +-- mod +pevalModIntegerTerm :: Term Integer -> Term Integer -> Term Integer +pevalModIntegerTerm = binaryUnfoldOnce doPevalModIntegerTerm modIntegerTerm + +doPevalModIntegerTerm :: Term Integer -> Term Integer -> Maybe (Term Integer) +doPevalModIntegerTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `mod` b +doPevalModIntegerTerm _ (ConTerm _ 1) = Just $ conTerm 0 +doPevalModIntegerTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 +doPevalModIntegerTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.Num + ( pattern NumConTerm, + pattern NumOrdConTerm, + pevalAddNumTerm, + pevalMinusNumTerm, + pevalTimesNumTerm, + pevalUMinusNumTerm, + pevalAbsNumTerm, + pevalSignumNumTerm, + pevalLtNumTerm, + pevalLeNumTerm, + pevalGtNumTerm, + pevalGeNumTerm, + ) +where + +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold +import Grisette.IR.SymPrim.Data.Prim.Utils +import Unsafe.Coerce + +numConTermView :: (Num b, Typeable b) => Term a -> Maybe b +numConTermView (ConTerm _ b) = cast b +numConTermView _ = Nothing + +pattern NumConTerm :: forall b a. (Num b, Typeable b) => b -> Term a +pattern NumConTerm b <- (numConTermView -> Just b) + +numOrdConTermView :: (Num b, Ord b, Typeable b) => Term a -> Maybe b +numOrdConTermView (ConTerm _ b) = cast b +numOrdConTermView _ = Nothing + +pattern NumOrdConTerm :: forall b a. (Num b, Ord b, Typeable b) => b -> Term a +pattern NumOrdConTerm b <- (numOrdConTermView -> Just b) + +-- add +pevalAddNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Term a +pevalAddNumTerm = binaryUnfoldOnce doPevalAddNumTerm (\a b -> normalizeAddNum $ addNumTerm a b) + +doPevalAddNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalAddNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a + b +doPevalAddNumTerm l@(ConTerm _ a) b = case (a, b) of + (0, k) -> Just k + (l1, AddNumTerm _ (ConTerm _ j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 + j) k + _ -> doPevalAddNumTermNoConc l b +doPevalAddNumTerm a r@(ConTerm _ _) = doPevalAddNumTerm r a +doPevalAddNumTerm l r = doPevalAddNumTermNoConc l r + +doPevalAddNumTermNoConc :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalAddNumTermNoConc (AddNumTerm _ i@ConTerm {} j) k = Just $ pevalAddNumTerm i $ pevalAddNumTerm j k +doPevalAddNumTermNoConc i (AddNumTerm _ j@ConTerm {} k) = Just $ pevalAddNumTerm j $ pevalAddNumTerm i k +doPevalAddNumTermNoConc (UMinusNumTerm _ i) (UMinusNumTerm _ j) = Just $ pevalUMinusNumTerm $ pevalAddNumTerm i j +doPevalAddNumTermNoConc (TimesNumTerm _ (ConTerm _ i) j) (TimesNumTerm _ (ConTerm _ k) l) + | j == l = Just $ pevalTimesNumTerm (conTerm $ i + k) j +doPevalAddNumTermNoConc (TimesNumTerm _ i@ConTerm {} j) (TimesNumTerm _ k@(ConTerm _ _) l) + | i == k = Just $ pevalTimesNumTerm i (pevalAddNumTerm j l) +doPevalAddNumTermNoConc _ _ = Nothing + +normalizeAddNum :: forall a. (Num a, Typeable a) => Term a -> Term a +normalizeAddNum (AddNumTerm _ l r@(ConTerm _ _)) = addNumTerm r l +normalizeAddNum v = v + +pevalMinusNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a -> Term a +pevalMinusNumTerm l r = pevalAddNumTerm l (pevalUMinusNumTerm r) + +-- uminus +pevalUMinusNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a +pevalUMinusNumTerm = unaryUnfoldOnce doPevalUMinusNumTerm uminusNumTerm + +doPevalUMinusNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a) +doPevalUMinusNumTerm (ConTerm _ a) = Just $ conTerm $ -a +doPevalUMinusNumTerm (UMinusNumTerm _ v) = Just v +doPevalUMinusNumTerm (AddNumTerm _ (NumConTerm l) r) = Just $ pevalMinusNumTerm (conTerm $ -l) r +doPevalUMinusNumTerm (AddNumTerm _ (UMinusNumTerm _ l) r) = Just $ pevalAddNumTerm l (pevalUMinusNumTerm r) +doPevalUMinusNumTerm (AddNumTerm _ l (UMinusNumTerm _ r)) = Just $ pevalAddNumTerm (pevalUMinusNumTerm l) r +doPevalUMinusNumTerm (TimesNumTerm _ (NumConTerm l) r) = Just $ pevalTimesNumTerm (conTerm $ -l) r +doPevalUMinusNumTerm (TimesNumTerm _ (UMinusNumTerm _ _ :: Term a) (_ :: Term a)) = error "Should not happen" +doPevalUMinusNumTerm (TimesNumTerm _ (_ :: Term a) (UMinusNumTerm _ (_ :: Term a))) = error "Should not happen" +doPevalUMinusNumTerm (AddNumTerm _ (_ :: Term a) ConTerm {}) = error "Should not happen" +doPevalUMinusNumTerm _ = Nothing + +-- times +pevalTimesNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Term a +pevalTimesNumTerm = binaryUnfoldOnce doPevalTimesNumTerm (\a b -> normalizeTimesNum $ timesNumTerm a b) + +normalizeTimesNum :: forall a. (Num a, Typeable a) => Term a -> Term a +normalizeTimesNum (TimesNumTerm _ l r@(ConTerm _ _)) = timesNumTerm r l +normalizeTimesNum v = v + +doPevalTimesNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalTimesNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a * b +doPevalTimesNumTerm l@(ConTerm _ a) b = case (a, b) of + (0, _) -> Just $ conTerm 0 + (1, k) -> Just k + (-1, k) -> Just $ pevalUMinusNumTerm k + (l1, TimesNumTerm _ (NumConTerm j) k) -> Just $ pevalTimesNumTerm (conTerm $ l1 * j) k + (l1, AddNumTerm _ (NumConTerm j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 * j) (pevalTimesNumTerm (conTerm l1) k) + (l1, UMinusNumTerm _ j) -> Just (pevalTimesNumTerm (conTerm $ -l1) j) + (_, TimesNumTerm _ (_ :: Term a) ConTerm {}) -> error "Should not happen" + (_, AddNumTerm _ (_ :: Term a) ConTerm {}) -> error "Should not happen" + _ -> doPevalTimesNumTermNoConc l b +doPevalTimesNumTerm a r@(ConTerm _ _) = doPevalTimesNumTerm r a +doPevalTimesNumTerm l r = doPevalTimesNumTermNoConc l r + +doPevalTimesNumTermNoConc :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) +doPevalTimesNumTermNoConc (TimesNumTerm _ i@ConTerm {} j) k = Just $ pevalTimesNumTerm i $ pevalTimesNumTerm j k +doPevalTimesNumTermNoConc i (TimesNumTerm _ j@ConTerm {} k) = Just $ pevalTimesNumTerm j $ pevalTimesNumTerm i k +doPevalTimesNumTermNoConc (UMinusNumTerm _ i) j = Just $ pevalUMinusNumTerm $ pevalTimesNumTerm i j +doPevalTimesNumTermNoConc i (UMinusNumTerm _ j) = Just $ pevalUMinusNumTerm $ pevalTimesNumTerm i j +doPevalTimesNumTermNoConc i j@ConTerm {} = Just $ pevalTimesNumTerm j i +doPevalTimesNumTermNoConc (TimesNumTerm _ (_ :: Term a) ConTerm {}) _ = error "Should not happen" +doPevalTimesNumTermNoConc _ (TimesNumTerm _ (_ :: Term a) ConTerm {}) = error "Should not happen" +doPevalTimesNumTermNoConc _ _ = Nothing + +-- abs +pevalAbsNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a +pevalAbsNumTerm = unaryUnfoldOnce doPevalAbsNumTerm absNumTerm + +doPevalAbsNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a) +doPevalAbsNumTerm (ConTerm _ a) = Just $ conTerm $ abs a +doPevalAbsNumTerm (UMinusNumTerm _ v) = Just $ pevalAbsNumTerm v +doPevalAbsNumTerm t@(AbsNumTerm _ (_ :: Term a)) = Just t +doPevalAbsNumTerm (TimesNumTerm _ (Dyn (l :: Term Integer)) r) = + Just $ pevalTimesNumTerm (pevalAbsNumTerm $ unsafeCoerce l :: Term a) $ pevalAbsNumTerm (unsafeCoerce r) +doPevalAbsNumTerm _ = Nothing + +-- signum +pevalSignumNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a +pevalSignumNumTerm = unaryUnfoldOnce doPevalSignumNumTerm signumNumTerm + +doPevalSignumNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a) +doPevalSignumNumTerm (ConTerm _ a) = Just $ conTerm $ signum a +doPevalSignumNumTerm (UMinusNumTerm _ (Dyn (v :: Term Integer))) = Just $ pevalUMinusNumTerm $ pevalSignumNumTerm $ unsafeCoerce v +doPevalSignumNumTerm (TimesNumTerm _ (Dyn (l :: Term Integer)) r) = + Just $ pevalTimesNumTerm (pevalSignumNumTerm $ unsafeCoerce l :: Term a) $ pevalSignumNumTerm (unsafeCoerce r) +doPevalSignumNumTerm _ = Nothing + +-- lt +pevalLtNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool +pevalLtNumTerm = binaryUnfoldOnce doPevalLtNumTerm ltNumTerm + +doPevalLtNumTerm :: forall a. (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Maybe (Term Bool) +doPevalLtNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a < b +doPevalLtNumTerm (ConTerm _ l) (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) = + Just $ pevalLtNumTerm (conTerm $ unsafeCoerce l - j) (unsafeCoerce k) +doPevalLtNumTerm (AddNumTerm _ (ConTerm _ (Dyn (i :: Integer))) j) (ConTerm _ k) = + Just $ pevalLtNumTerm (unsafeCoerce j) (conTerm $ unsafeCoerce k - i) +doPevalLtNumTerm (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) l = + Just $ pevalLtNumTerm (conTerm j) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce k)) +doPevalLtNumTerm j (AddNumTerm _ (ConTerm _ (Dyn (k :: Integer))) l) = + Just $ pevalLtNumTerm (conTerm $ -k) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce j)) +doPevalLtNumTerm l (ConTerm _ r) = + case eqT @a @Integer of + Just Refl -> + Just $ pevalLtNumTerm (conTerm $ -r) (pevalUMinusNumTerm l) + _ -> Nothing +doPevalLtNumTerm _ _ = Nothing + +-- le +pevalLeNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool +pevalLeNumTerm = binaryUnfoldOnce doPevalLeNumTerm leNumTerm + +doPevalLeNumTerm :: forall a. (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Maybe (Term Bool) +doPevalLeNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a <= b +doPevalLeNumTerm (ConTerm _ l) (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) = + Just $ pevalLeNumTerm (conTerm $ unsafeCoerce l - j) (unsafeCoerce k) +doPevalLeNumTerm (AddNumTerm _ (ConTerm _ (Dyn (i :: Integer))) j) (ConTerm _ k) = + Just $ pevalLeNumTerm (unsafeCoerce j) (conTerm $ unsafeCoerce k - i) +doPevalLeNumTerm (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) l = + Just $ pevalLeNumTerm (conTerm j) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce k)) +doPevalLeNumTerm j (AddNumTerm _ (ConTerm _ (Dyn (k :: Integer))) l) = + Just $ pevalLeNumTerm (conTerm $ -k) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce j)) +doPevalLeNumTerm l (ConTerm _ r) = + case eqT @a @Integer of + Just Refl -> + Just $ pevalLeNumTerm (conTerm $ -r) (pevalUMinusNumTerm l) + _ -> Nothing +doPevalLeNumTerm _ _ = Nothing + +pevalGtNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool +pevalGtNumTerm = flip pevalLtNumTerm + +pevalGeNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool +pevalGeNumTerm = flip pevalLeNumTerm diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval + ( PartialFun, + PartialRuleUnary, + TotalRuleUnary, + PartialRuleBinary, + TotalRuleBinary, + totalize, + totalize2, + UnaryPartialStrategy (..), + unaryPartial, + BinaryCommPartialStrategy (..), + BinaryPartialStrategy (..), + binaryPartial, + ) +where + +import Control.Monad.Except +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term + +type PartialFun a b = a -> Maybe b + +type PartialRuleUnary a b = PartialFun (Term a) (Term b) + +type TotalRuleUnary a b = Term a -> Term b + +type PartialRuleBinary a b c = Term a -> PartialFun (Term b) (Term c) + +type TotalRuleBinary a b c = Term a -> Term b -> Term c + +totalize :: PartialFun a b -> (a -> b) -> a -> b +totalize partial fallback a = + case partial a of + Just b -> b + Nothing -> fallback a + +totalize2 :: (a -> PartialFun b c) -> (a -> b -> c) -> a -> b -> c +totalize2 partial fallback a b = + case partial a b of + Just c -> c + Nothing -> fallback a b + +class UnaryPartialStrategy tag a b | tag a -> b where + extractor :: tag -> Term a -> Maybe a + constantHandler :: tag -> a -> Maybe (Term b) + nonConstantHandler :: tag -> Term a -> Maybe (Term b) + +unaryPartial :: forall tag a b. (UnaryPartialStrategy tag a b) => tag -> PartialRuleUnary a b +unaryPartial tag a = case extractor tag a of + Nothing -> nonConstantHandler tag a + Just a' -> constantHandler tag a' + +class BinaryCommPartialStrategy tag a c | tag a -> c where + singleConstantHandler :: tag -> a -> Term a -> Maybe (Term c) + +class BinaryPartialStrategy tag a b c | tag a b -> c where + extractora :: tag -> Term a -> Maybe a + extractorb :: tag -> Term b -> Maybe b + allConstantHandler :: tag -> a -> b -> Maybe (Term c) + leftConstantHandler :: tag -> a -> Term b -> Maybe (Term c) + default leftConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> a -> Term b -> Maybe (Term c) + leftConstantHandler = singleConstantHandler @tag @a + rightConstantHandler :: tag -> Term a -> b -> Maybe (Term c) + default rightConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> Term a -> b -> Maybe (Term c) + rightConstantHandler tag = flip $ singleConstantHandler @tag @a tag + nonBinaryConstantHandler :: tag -> Term a -> Term b -> Maybe (Term c) + +binaryPartial :: forall tag a b c. (BinaryPartialStrategy tag a b c) => tag -> PartialRuleBinary a b c +binaryPartial tag a b = case (extractora @tag @a @b @c tag a, extractorb @tag @a @b @c tag b) of + (Nothing, Nothing) -> nonBinaryConstantHandler @tag @a @b @c tag a b + (Just a', Nothing) -> + leftConstantHandler @tag @a @b @c tag a' b + `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b + (Nothing, Just b') -> + rightConstantHandler @tag @a @b @c tag a b' + `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b + (Just a', Just b') -> + allConstantHandler @tag @a @b @c tag a' b' diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun + ( pevalTabularFunApplyTerm, + ) +where + +import Grisette.Core.Data.Class.Function +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval +import Grisette.IR.SymPrim.Data.TabularFun + +pevalTabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b +pevalTabularFunApplyTerm = totalize2 doPevalTabularFunApplyTerm tabularFunApplyTerm + +doPevalTabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Maybe (Term b) +doPevalTabularFunApplyTerm (ConTerm _ f) (ConTerm _ a) = Just $ conTerm $ f # a +doPevalTabularFunApplyTerm (ConTerm _ (TabularFun f d)) a = Just $ go f + where + go [] = conTerm d + go ((x, y) : xs) = pevalITETerm (pevalEqvTerm a (conTerm x)) (conTerm y) (go xs) +doPevalTabularFunApplyTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold + ( unaryUnfoldOnce, + binaryUnfoldOnce, + ) +where + +import Control.Monad.Except +import Data.Typeable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval + +unaryPartialUnfoldOnce :: + forall a b. + (Typeable a, SupportedPrim b) => + PartialRuleUnary a b -> + TotalRuleUnary a b -> + PartialRuleUnary a b +unaryPartialUnfoldOnce partial fallback = ret + where + oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b + oneLevel fallback' x = case (x, partial x) of + (ITETerm _ cond vt vf, pr) -> + let pt = partial vt + pf = partial vf + in case (pt, pf) of + (Nothing, Nothing) -> pr + (mt, mf) -> + pevalITETerm cond + <$> catchError mt (\_ -> Just $ totalize (oneLevel fallback') fallback' vt) + <*> catchError mf (\_ -> Just $ totalize (oneLevel fallback') fallback vf) + (_, pr) -> pr + ret :: PartialRuleUnary a b + ret = oneLevel (totalize @(Term a) @(Term b) partial fallback) + +unaryUnfoldOnce :: + forall a b. + (Typeable a, SupportedPrim b) => + PartialRuleUnary a b -> + TotalRuleUnary a b -> + TotalRuleUnary a b +unaryUnfoldOnce partial fallback = totalize (unaryPartialUnfoldOnce partial fallback) fallback + +binaryPartialUnfoldOnce :: + forall a b c. + (Typeable a, Typeable b, SupportedPrim c) => + PartialRuleBinary a b c -> + TotalRuleBinary a b c -> + PartialRuleBinary a b c +binaryPartialUnfoldOnce partial fallback = ret + where + oneLevel :: (Typeable x, Typeable y) => PartialRuleBinary x y c -> TotalRuleBinary x y c -> PartialRuleBinary x y c + oneLevel partial' fallback' x y = + catchError + (partial' x y) + ( \_ -> + catchError + ( case x of + ITETerm _ cond vt vf -> left cond vt vf y partial' fallback' + _ -> Nothing + ) + ( \_ -> case y of + ITETerm _ cond vt vf -> left cond vt vf x (flip partial') (flip fallback') + _ -> Nothing + ) + ) + left :: + (Typeable x, Typeable y) => + Term Bool -> + Term x -> + Term x -> + Term y -> + PartialRuleBinary x y c -> + TotalRuleBinary x y c -> + Maybe (Term c) + left cond vt vf y partial' fallback' = + let pt = partial' vt y + pf = partial' vf y + in case (pt, pf) of + (Nothing, Nothing) -> Nothing + (mt, mf) -> + pevalITETerm cond + <$> catchError mt (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vt y) + <*> catchError mf (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vf y) + ret :: PartialRuleBinary a b c + ret = oneLevel partial (totalize2 @(Term a) @(Term b) @(Term c) partial fallback) + +binaryUnfoldOnce :: + forall a b c. + (Typeable a, Typeable b, SupportedPrim c) => + PartialRuleBinary a b c -> + TotalRuleBinary a b c -> + TotalRuleBinary a b c +binaryUnfoldOnce partial fallback = totalize2 (binaryPartialUnfoldOnce partial fallback) fallback diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Utils.hs b/src/Grisette/IR/SymPrim/Data/Prim/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/Prim/Utils.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.Prim.Utils +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.Prim.Utils + ( pattern Dyn, + cmpHetero, + eqHetero, + cmpHeteroRep, + eqHeteroRep, + eqTypeRepBool, + ) +where + +import Data.Typeable (cast) +import Type.Reflection + +pattern Dyn :: (Typeable a, Typeable b) => a -> b +pattern Dyn x <- (cast -> Just x) + +cmpHeteroRep :: forall a b. TypeRep a -> TypeRep b -> (a -> a -> Bool) -> a -> b -> Bool +cmpHeteroRep ta tb f a b = case eqTypeRep ta tb of + Just HRefl -> f a b + _ -> False +{-# INLINE cmpHeteroRep #-} + +cmpHetero :: forall a b. (Typeable a, Typeable b) => (a -> a -> Bool) -> a -> b -> Bool +cmpHetero = cmpHeteroRep (typeRep @a) (typeRep @b) +{-# INLINE cmpHetero #-} + +eqHetero :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool +eqHetero = cmpHetero (==) +{-# INLINE eqHetero #-} + +eqHeteroRep :: forall a b. Eq a => TypeRep a -> TypeRep b -> a -> b -> Bool +eqHeteroRep ta tb = cmpHeteroRep ta tb (==) +{-# INLINE eqHeteroRep #-} + +eqTypeRepBool :: forall ka kb (a :: ka) (b :: kb). TypeRep a -> TypeRep b -> Bool +eqTypeRepBool a b = case eqTypeRep a b of + Just HRefl -> True + _ -> False +{-# INLINE eqTypeRepBool #-} diff --git a/src/Grisette/IR/SymPrim/Data/SymPrim.hs b/src/Grisette/IR/SymPrim/Data/SymPrim.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/SymPrim.hs @@ -0,0 +1,632 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.SymPrim +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.SymPrim + ( Sym (..), + SymBool, + SymInteger, + (-->), + type (=~>), + type (-~>), + SymWordN, + SymIntN, + symSize, + symsSize, + ModelSymPair (..), + ) +where + +import Control.DeepSeq +import Control.Monad.Except +import Data.Bits +import Data.Hashable +import Data.Int +import Data.Proxy +import Data.String +import Data.Word +import GHC.Generics +import GHC.TypeLits +import Grisette.Core.Data.Class.BitVector +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Error +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Function +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.Integer +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.ModelOps +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.Substitute +import Grisette.Core.Data.Class.ToCon +import Grisette.Core.Data.Class.ToSym +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.IntBitwidth +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.Prim.Model +import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +import Grisette.IR.SymPrim.Data.TabularFun +import Grisette.Lib.Control.Monad +import Language.Haskell.TH.Syntax + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.Backend.SBV + +-- | Symbolic primitive type. +-- +-- Symbolic Boolean, integer, and bit vector types are supported. +-- +-- >>> :set -XOverloadedStrings +-- >>> "a" :: Sym Bool +-- a +-- >>> "a" &&~ "b" :: Sym Bool +-- (&& a b) +-- >>> "i" + 1 :: Sym Integer +-- (+ 1 i) +-- +-- For more symbolic operations, please refer to the documentation of the +-- [grisette-core](https://hackage.haskell.org/package/grisette-core) package. +-- +-- Grisette also supports uninterpreted functions. You can use the '-->' +-- (general function) or '=->' (tabular function) types to define uninterpreted +-- functions. The following code shows the examples +-- +-- >>> :set -XTypeOperators +-- >>> let ftab = "ftab" :: Sym (Integer =-> Integer) +-- >>> ftab # "x" +-- (apply ftab x) +-- +-- > >>> solve (UnboundedReasoning z3) (ftab # 1 ==~ 2 &&~ ftab # 2 ==~ 3 &&~ ftab # 3 ==~ 4) +-- > Right (Model { +-- > ftab -> +-- > TabularFun {funcTable = [(3,4),(2,3)], defaultFuncValue = 2} +-- > :: (=->) Integer Integer +-- > }) -- possible result (reformatted) +-- +-- >>> let fgen = "fgen" :: Sym (Integer --> Integer) +-- >>> fgen # "x" +-- (apply fgen x) +-- +-- > >>> solve (UnboundedReasoning z3) (fgen # 1 ==~ 2 &&~ fgen # 2 ==~ 3 &&~ fgen # 3 ==~ 4) +-- > Right (Model { +-- > fgen -> +-- > \(arg@0:FuncArg :: Integer) -> +-- > (ite (= arg@0:FuncArg 2) 3 (ite (= arg@0:FuncArg 3) 4 2)) +-- > :: (-->) Integer Integer +-- > }) -- possible result (reformatted) +newtype Sym a = Sym {underlyingTerm :: Term a} deriving (Lift, Generic) + +instance NFData (Sym a) where + rnf (Sym t) = rnf t + +instance (SupportedPrim a) => Solvable a (Sym a) where + con = Sym . conTerm + ssym = Sym . ssymTerm + isym str i = Sym $ isymTerm str i + sinfosym str info = Sym $ sinfosymTerm str info + iinfosym str i info = Sym $ iinfosymTerm str i info + conView (Sym (ConTerm _ t)) = Just t + conView _ = Nothing + +instance (SupportedPrim t) => IsString (Sym t) where + fromString = ssym + +instance (SupportedPrim a) => ToSym (Sym a) (Sym a) where + toSym = id + +instance (SupportedPrim a) => ToSym a (Sym a) where + toSym = con + +instance (SupportedPrim a) => ToCon (Sym a) (Sym a) where + toCon = Just + +instance (SupportedPrim a) => ToCon (Sym a) a where + toCon = conView + +instance (SupportedPrim a) => EvaluateSym (Sym a) where + evaluateSym fillDefault model (Sym t) = Sym $ evaluateTerm fillDefault model t + +instance (SupportedPrim a) => ExtractSymbolics (Sym a) where + extractSymbolics (Sym t) = SymbolSet $ extractSymbolicsTerm t + +instance (SupportedPrim a) => Show (Sym a) where + show (Sym t) = pformat t + +instance (SupportedPrim a) => Hashable (Sym a) where + hashWithSalt s (Sym v) = s `hashWithSalt` v + +instance (SupportedPrim a) => Eq (Sym a) where + (Sym l) == (Sym r) = l == r + +#define SEQ_SYM(type) \ +instance (SupportedPrim type) => SEq (Sym type) where \ + (Sym l) ==~ (Sym r) = Sym $ pevalEqvTerm l r + +#define SORD_SYM(type) \ +instance (SupportedPrim type) => SOrd (Sym type) where \ + (Sym a) <=~ (Sym b) = Sym $ withPrim (Proxy @type) $ pevalLeNumTerm a b; \ + (Sym a) <~ (Sym b) = Sym $ withPrim (Proxy @type) $ pevalLtNumTerm a b; \ + (Sym a) >=~ (Sym b) = Sym $ withPrim (Proxy @type) $ pevalGeNumTerm a b; \ + (Sym a) >~ (Sym b) = Sym $ withPrim (Proxy @type) $ pevalGtNumTerm a b; \ + a `symCompare` b = \ + withPrim (Proxy @type) $ mrgIf \ + (a <~ b) \ + (mrgReturn LT) \ + (mrgIf (a ==~ b) (mrgReturn EQ) (mrgReturn GT)) + +#if 1 +SEQ_SYM(Bool) +SEQ_SYM(Integer) +SEQ_SYM((IntN n)) +SEQ_SYM((WordN n)) +SORD_SYM(Integer) +SORD_SYM((IntN n)) +SORD_SYM((WordN n)) +#endif + +-- | Symbolic Boolean type. +type SymBool = Sym Bool + +instance SOrd (Sym Bool) where + l <=~ r = nots l ||~ r + l <~ r = nots l &&~ r + l >=~ r = l ||~ nots r + l >~ r = l &&~ nots r + symCompare l r = + mrgIf + (nots l &&~ r) + (mrgReturn LT) + (mrgIf (l ==~ r) (mrgReturn EQ) (mrgReturn GT)) + +instance SymBoolOp (Sym Bool) + +-- | Symbolic integer type (unbounded, mathematical integer). +type SymInteger = Sym Integer + +instance Num (Sym Integer) where + (Sym l) + (Sym r) = Sym $ pevalAddNumTerm l r + (Sym l) - (Sym r) = Sym $ pevalMinusNumTerm l r + (Sym l) * (Sym r) = Sym $ pevalTimesNumTerm l r + negate (Sym v) = Sym $ pevalUMinusNumTerm v + abs (Sym v) = Sym $ pevalAbsNumTerm v + signum (Sym v) = Sym $ pevalSignumNumTerm v + fromInteger = con + +instance SignedDivMod (Sym Integer) where + divs (Sym l) rs@(Sym r) = + mrgIf + (rs ==~ con 0) + (throwError $ transformError DivideByZero) + (mrgReturn $ Sym $ pevalDivIntegerTerm l r) + mods (Sym l) rs@(Sym r) = + mrgIf + (rs ==~ con 0) + (throwError $ transformError DivideByZero) + (mrgReturn $ Sym $ pevalModIntegerTerm l r) + +instance SymIntegerOp (Sym Integer) + +-- | Symbolic signed bit vector type. +type SymIntN n = Sym (IntN n) + +instance (SupportedPrim (IntN n)) => Num (Sym (IntN n)) where + (Sym l) + (Sym r) = Sym $ withPrim (Proxy @(IntN n)) $ pevalAddNumTerm l r + (Sym l) - (Sym r) = Sym $ withPrim (Proxy @(IntN n)) $ pevalMinusNumTerm l r + (Sym l) * (Sym r) = Sym $ withPrim (Proxy @(IntN n)) $ pevalTimesNumTerm l r + negate (Sym v) = Sym $ withPrim (Proxy @(IntN n)) $ pevalUMinusNumTerm v + abs (Sym v) = Sym $ withPrim (Proxy @(IntN n)) $ pevalAbsNumTerm v + signum (Sym v) = Sym $ withPrim (Proxy @(IntN n)) $ pevalSignumNumTerm v + fromInteger i = withPrim (Proxy @(IntN n)) $ con $ fromInteger i + +instance (SupportedPrim (IntN n)) => Bits (Sym (IntN n)) where + Sym l .&. Sym r = Sym $ withPrim (Proxy @(IntN n)) $ pevalAndBitsTerm l r + Sym l .|. Sym r = Sym $ withPrim (Proxy @(IntN n)) $ pevalOrBitsTerm l r + Sym l `xor` Sym r = Sym $ withPrim (Proxy @(IntN n)) $ pevalXorBitsTerm l r + complement (Sym n) = Sym $ withPrim (Proxy @(IntN n)) $ pevalComplementBitsTerm n + shift (Sym n) i = Sym $ withPrim (Proxy @(IntN n)) $ pevalShiftBitsTerm n i + rotate (Sym n) i = Sym $ withPrim (Proxy @(IntN n)) $ pevalRotateBitsTerm n i + bitSize _ = fromInteger $ withPrim (Proxy @(IntN n)) $ natVal (Proxy @n) + bitSizeMaybe _ = Just $ fromInteger $ withPrim (Proxy @(IntN n)) $ natVal (Proxy @n) + isSigned _ = True + testBit (Con n) = withPrim (Proxy @(IntN n)) $ testBit n + testBit _ = error "You cannot call testBit on symbolic variables" + bit = withPrim (Proxy @(IntN n)) $ con . bit + popCount (Con n) = withPrim (Proxy @(IntN n)) $ popCount n + popCount _ = error "You cannot call popCount on symbolic variables" + +instance + (KnownNat w', KnownNat n, KnownNat w, w' ~ (n + w), 1 <= n, 1 <= w, 1 <= w') => + BVConcat (Sym (IntN n)) (Sym (IntN w)) (Sym (IntN w')) + where + bvconcat (Sym l) (Sym r) = Sym (pevalBVConcatTerm l r) + +instance + ( KnownNat w, + KnownNat w', + 1 <= w, + 1 <= w', + w <= w', + w + 1 <= w', + 1 <= w' - w, + KnownNat (w' - w) + ) => + BVExtend (Sym (IntN w)) w' (Sym (IntN w')) + where + bvzeroExtend _ (Sym v) = Sym $ pevalBVExtendTerm False (Proxy @w') v + bvsignExtend _ (Sym v) = Sym $ pevalBVExtendTerm True (Proxy @w') v + bvextend = bvsignExtend + +instance + ( KnownNat ix, + KnownNat w, + KnownNat ow, + ix + w <= ow, + 1 <= ow, + 1 <= w + ) => + BVSelect (Sym (IntN ow)) ix w (Sym (IntN w)) + where + bvselect pix pw (Sym v) = Sym $ pevalBVSelectTerm pix pw v + +#define TOSYM_MACHINE_INTEGER(int, bv) \ +instance ToSym int (Sym (bv)) where \ + toSym = fromIntegral + +#define TOCON_MACHINE_INTEGER(bvw, n, int) \ +instance ToCon (Sym (bvw n)) int where \ + toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \ + toCon _ = Nothing + +#if 1 +TOSYM_MACHINE_INTEGER(Int8, IntN 8) +TOSYM_MACHINE_INTEGER(Int16, IntN 16) +TOSYM_MACHINE_INTEGER(Int32, IntN 32) +TOSYM_MACHINE_INTEGER(Int64, IntN 64) +TOSYM_MACHINE_INTEGER(Word8, WordN 8) +TOSYM_MACHINE_INTEGER(Word16, WordN 16) +TOSYM_MACHINE_INTEGER(Word32, WordN 32) +TOSYM_MACHINE_INTEGER(Word64, WordN 64) +TOSYM_MACHINE_INTEGER(Int, IntN $intBitwidthQ) +TOSYM_MACHINE_INTEGER(Word, WordN $intBitwidthQ) + +TOCON_MACHINE_INTEGER(IntN, 8, Int8) +TOCON_MACHINE_INTEGER(IntN, 16, Int16) +TOCON_MACHINE_INTEGER(IntN, 32, Int32) +TOCON_MACHINE_INTEGER(IntN, 64, Int64) +TOCON_MACHINE_INTEGER(WordN, 8, Word8) +TOCON_MACHINE_INTEGER(WordN, 16, Word16) +TOCON_MACHINE_INTEGER(WordN, 32, Word32) +TOCON_MACHINE_INTEGER(WordN, 64, Word64) +TOCON_MACHINE_INTEGER(IntN, $intBitwidthQ, Int) +TOCON_MACHINE_INTEGER(WordN, $intBitwidthQ, Word) +#endif + +-- | Symbolic unsigned bit vector type. +type SymWordN n = Sym (WordN n) + +instance (SupportedPrim (WordN n)) => Num (Sym (WordN n)) where + (Sym l) + (Sym r) = Sym $ withPrim (Proxy @(WordN n)) $ pevalAddNumTerm l r + (Sym l) - (Sym r) = Sym $ withPrim (Proxy @(WordN n)) $ pevalMinusNumTerm l r + (Sym l) * (Sym r) = Sym $ withPrim (Proxy @(WordN n)) $ pevalTimesNumTerm l r + negate (Sym v) = Sym $ withPrim (Proxy @(WordN n)) $ pevalUMinusNumTerm v + abs (Sym v) = Sym $ withPrim (Proxy @(WordN n)) $ pevalAbsNumTerm v + signum (Sym v) = Sym $ withPrim (Proxy @(WordN n)) $ pevalSignumNumTerm v + fromInteger i = withPrim (Proxy @(WordN n)) $ con $ fromInteger i + +instance + (KnownNat w', KnownNat n, KnownNat w, w' ~ (n + w), 1 <= n, 1 <= w, 1 <= w') => + BVConcat (Sym (WordN n)) (Sym (WordN w)) (Sym (WordN w')) + where + bvconcat (Sym l) (Sym r) = Sym (pevalBVConcatTerm l r) + +instance + ( KnownNat w, + KnownNat w', + 1 <= w, + 1 <= w', + w + 1 <= w', + w <= w', + 1 <= w' - w, + KnownNat (w' - w) + ) => + BVExtend (Sym (WordN w)) w' (Sym (WordN w')) + where + bvzeroExtend _ (Sym v) = Sym $ pevalBVExtendTerm False (Proxy @w') v + bvsignExtend _ (Sym v) = Sym $ pevalBVExtendTerm True (Proxy @w') v + bvextend = bvzeroExtend + +instance + ( KnownNat ix, + KnownNat w, + KnownNat ow, + ix + w <= ow, + 1 <= ow, + 1 <= w + ) => + BVSelect (Sym (WordN ow)) ix w (Sym (WordN w)) + where + bvselect pix pw (Sym v) = Sym $ pevalBVSelectTerm pix pw v + +instance (SupportedPrim (WordN n)) => Bits (Sym (WordN n)) where + Sym l .&. Sym r = Sym $ withPrim (Proxy @(WordN n)) $ pevalAndBitsTerm l r + Sym l .|. Sym r = Sym $ withPrim (Proxy @(WordN n)) $ pevalOrBitsTerm l r + Sym l `xor` Sym r = Sym $ withPrim (Proxy @(WordN n)) $ pevalXorBitsTerm l r + complement (Sym n) = Sym $ withPrim (Proxy @(WordN n)) $ pevalComplementBitsTerm n + shift (Sym n) i = Sym $ withPrim (Proxy @(WordN n)) $ pevalShiftBitsTerm n i + rotate (Sym n) i = Sym $ withPrim (Proxy @(WordN n)) $ pevalRotateBitsTerm n i + bitSize _ = fromInteger $ withPrim (Proxy @(WordN n)) $ natVal (Proxy @n) + bitSizeMaybe _ = Just $ fromInteger $ withPrim (Proxy @(WordN n)) $ natVal (Proxy @n) + isSigned _ = False + testBit (Con n) = withPrim (Proxy @(WordN n)) $ testBit n + testBit _ = error "You cannot call testBit on symbolic variables" + bit = withPrim (Proxy @(WordN n)) $ con . bit + popCount (Con n) = withPrim (Proxy @(WordN n)) $ popCount n + popCount _ = error "You cannot call popCount on symbolic variables" + +-- | +-- Symbolic tabular function type. +type a =~> b = Sym (a =-> b) + +infixr 0 =~> + +instance (SupportedPrim a, SupportedPrim b) => Function (a =~> b) where + type Arg (a =~> b) = Sym a + type Ret (a =~> b) = Sym b + (Sym f) # (Sym t) = Sym $ pevalTabularFunApplyTerm f t + +-- | +-- Symbolic general function type. +type a -~> b = Sym (a --> b) + +infixr 0 -~> + +instance (SupportedPrim a, SupportedPrim b) => Function (a -~> b) where + type Arg (a -~> b) = Sym a + type Ret (a -~> b) = Sym b + (Sym f) # (Sym t) = Sym $ pevalGeneralFunApplyTerm f t + +-- | Get the sum of the sizes of a list of symbolic terms. +-- Duplicate sub-terms are counted for only once. +symsSize :: [Sym a] -> Int +symsSize = termsSize . fmap underlyingTerm + +-- | Get the size of a symbolic term. +-- Duplicate sub-terms are counted for only once. +symSize :: Sym a -> Int +symSize = termSize . underlyingTerm + +data ModelSymPair t = (Sym t) := t deriving (Show) + +instance ModelRep (ModelSymPair t) Model SymbolSet TypedSymbol where + buildModel (Sym (SymTerm _ sym) := val) = insertValue sym val emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b, + ModelSymPair c + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2, + Sym (SymTerm _ sym3) := val3 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + . insertValue sym3 val3 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b, + ModelSymPair c, + ModelSymPair d + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2, + Sym (SymTerm _ sym3) := val3, + Sym (SymTerm _ sym4) := val4 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + . insertValue sym3 val3 + . insertValue sym4 val4 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b, + ModelSymPair c, + ModelSymPair d, + ModelSymPair e + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2, + Sym (SymTerm _ sym3) := val3, + Sym (SymTerm _ sym4) := val4, + Sym (SymTerm _ sym5) := val5 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + . insertValue sym3 val3 + . insertValue sym4 val4 + . insertValue sym5 val5 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b, + ModelSymPair c, + ModelSymPair d, + ModelSymPair e, + ModelSymPair f + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2, + Sym (SymTerm _ sym3) := val3, + Sym (SymTerm _ sym4) := val4, + Sym (SymTerm _ sym5) := val5, + Sym (SymTerm _ sym6) := val6 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + . insertValue sym3 val3 + . insertValue sym4 val4 + . insertValue sym5 val5 + . insertValue sym6 val6 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b, + ModelSymPair c, + ModelSymPair d, + ModelSymPair e, + ModelSymPair f, + ModelSymPair g + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2, + Sym (SymTerm _ sym3) := val3, + Sym (SymTerm _ sym4) := val4, + Sym (SymTerm _ sym5) := val5, + Sym (SymTerm _ sym6) := val6, + Sym (SymTerm _ sym7) := val7 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + . insertValue sym3 val3 + . insertValue sym4 val4 + . insertValue sym5 val5 + . insertValue sym6 val6 + . insertValue sym7 val7 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance + ModelRep + ( ModelSymPair a, + ModelSymPair b, + ModelSymPair c, + ModelSymPair d, + ModelSymPair e, + ModelSymPair f, + ModelSymPair g, + ModelSymPair h + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( Sym (SymTerm _ sym1) := val1, + Sym (SymTerm _ sym2) := val2, + Sym (SymTerm _ sym3) := val3, + Sym (SymTerm _ sym4) := val4, + Sym (SymTerm _ sym5) := val5, + Sym (SymTerm _ sym6) := val6, + Sym (SymTerm _ sym7) := val7, + Sym (SymTerm _ sym8) := val8 + ) = + insertValue sym1 val1 + . insertValue sym2 val2 + . insertValue sym3 val3 + . insertValue sym4 val4 + . insertValue sym5 val5 + . insertValue sym6 val6 + . insertValue sym7 val7 + . insertValue sym8 val8 + $ emptyModel + buildModel _ = error "buildModel: should only use symbolic constants" + +instance (SupportedPrim a, SupportedPrim b) => Function (a --> b) where + type Arg (a --> b) = Sym a + type Ret (a --> b) = Sym b + (GeneralFun arg tm) # (Sym v) = Sym $ substTerm arg v tm + +-- | Construction of general symbolic functions. +(-->) :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Sym b -> a --> b +(-->) arg (Sym v) = GeneralFun arg v diff --git a/src/Grisette/IR/SymPrim/Data/SymPrim.hs-boot b/src/Grisette/IR/SymPrim/Data/SymPrim.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/SymPrim.hs-boot @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Grisette.IR.SymPrim.Data.SymPrim (Sym (..), SymBool) where + +import Control.DeepSeq +import Data.Hashable +import GHC.Generics +import {-# SOURCE #-} Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Solvable +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Language.Haskell.TH.Syntax + +newtype Sym a = Sym {underlyingTerm :: Term a} + +type SymBool = Sym Bool + +instance NFData (Sym a) + +instance Lift (Sym a) + +instance (SupportedPrim a) => Solvable a (Sym a) + +instance (SupportedPrim a) => Eq (Sym a) + +instance (SupportedPrim a) => Hashable (Sym a) + +instance (SupportedPrim a) => Show (Sym a) + +instance (SupportedPrim a) => EvaluateSym (Sym a) + +instance (SupportedPrim a) => ExtractSymbolics (Sym a) diff --git a/src/Grisette/IR/SymPrim/Data/TabularFun.hs b/src/Grisette/IR/SymPrim/Data/TabularFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/TabularFun.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.IR.SymPrim.Data.TabularFun +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.IR.SymPrim.Data.TabularFun + ( type (=->) (..), + ) +where + +import Control.DeepSeq +import Data.Hashable +import GHC.Generics +import Grisette.Core.Data.Class.Function +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Language.Haskell.TH.Syntax + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.IR.SymPrim + +-- | +-- Functions as a table. Use the `#` operator to apply the function. +-- +-- >>> :set -XTypeOperators +-- >>> let f = TabularFun [(1, 2), (3, 4)] 0 :: Int =-> Int +-- >>> f # 1 +-- 2 +-- >>> f # 2 +-- 0 +-- >>> f # 3 +-- 4 +data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b} + deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1) + +infixr 0 =-> + +instance + (SupportedPrim a, SupportedPrim b) => + SupportedPrim (a =-> b) + where + type PrimConstraint (a =-> b) = (SupportedPrim a, SupportedPrim b) + defaultValue = TabularFun [] (defaultValue @b) + +instance (Eq a) => Function (a =-> b) where + type Arg (a =-> b) = a + type Ret (a =-> b) = b + (TabularFun table d) # a = go table + where + go [] = d + go ((av, bv) : s) + | a == av = bv + | otherwise = go s + +instance (Hashable a, Hashable b) => Hashable (a =-> b) diff --git a/src/Grisette/IR/SymPrim/Data/TabularFun.hs-boot b/src/Grisette/IR/SymPrim/Data/TabularFun.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/IR/SymPrim/Data/TabularFun.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeOperators #-} + +module Grisette.IR.SymPrim.Data.TabularFun + ( type (=->) (..), + ) +where + +data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b} diff --git a/src/Grisette/Internal/Backend/SBV.hs b/src/Grisette/Internal/Backend/SBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Backend/SBV.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Grisette.Internal.Backend.SBV +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Backend.SBV + ( lowerSinglePrim, + parseModel, + TermTy, + ) +where + +import Grisette.Backend.SBV.Data.SMT.Lowering +import Grisette.Backend.SBV.Data.SMT.Solving diff --git a/src/Grisette/Internal/Core.hs b/src/Grisette/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Internal.Core +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core + ( -- * The UnionBase type + Union (..), + ifWithLeftMost, + ifWithStrategy, + fullReconstruct, + + -- * The UnionMBase type + UnionM (..), + underlyingUnion, + isMerged, + ) +where + +import Grisette.Core.Control.Monad.UnionM +import Grisette.Core.Data.Union diff --git a/src/Grisette/Internal/IR/SymPrim.hs b/src/Grisette/Internal/IR/SymPrim.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/IR/SymPrim.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- Module : Grisette.Internal.IR.SymPrim +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.IR.SymPrim + ( FunArg (..), + Sym (..), + UnaryOp (..), + BinaryOp (..), + TernaryOp (..), + Term (..), + showUntyped, + withSymbolSupported, + SomeTypedSymbol (..), + someTypedSymbol, + evaluateTerm, + introSupportedPrimConstraint, + SomeTerm (..), + SupportedPrim (..), + castTerm, + identity, + identityWithTypeRep, + pformat, + constructUnary, + constructBinary, + constructTernary, + conTerm, + symTerm, + ssymTerm, + isymTerm, + sinfosymTerm, + iinfosymTerm, + termSize, + termsSize, + extractSymbolicsTerm, + trueTerm, + falseTerm, + pattern BoolConTerm, + pattern TrueTerm, + pattern FalseTerm, + pattern BoolTerm, + pevalNotTerm, + pevalEqvTerm, + pevalNotEqvTerm, + pevalOrTerm, + pevalAndTerm, + pevalITETerm, + pevalImplyTerm, + pevalXorTerm, + unaryUnfoldOnce, + binaryUnfoldOnce, + pattern UnaryTermPatt, + pattern BinaryTermPatt, + pattern TernaryTermPatt, + PartialFun, + PartialRuleUnary, + TotalRuleUnary, + PartialRuleBinary, + TotalRuleBinary, + totalize, + totalize2, + UnaryPartialStrategy (..), + unaryPartial, + BinaryCommPartialStrategy (..), + BinaryPartialStrategy (..), + binaryPartial, + pattern NumConTerm, + pattern NumOrdConTerm, + pevalAddNumTerm, + pevalMinusNumTerm, + pevalUMinusNumTerm, + pevalAbsNumTerm, + pevalSignumNumTerm, + pevalTimesNumTerm, + pevalLtNumTerm, + pevalLeNumTerm, + pevalGtNumTerm, + pevalGeNumTerm, + pevalTabularFunApplyTerm, + pevalGeneralFunApplyTerm, + pevalDivIntegerTerm, + pevalModIntegerTerm, + ) +where + +import Grisette.IR.SymPrim.Data.Prim.Helpers +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.Prim.Model +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval +import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold +import Grisette.IR.SymPrim.Data.SymPrim diff --git a/src/Grisette/Lib/Base.hs b/src/Grisette/Lib/Base.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Base.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Base +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Base + ( -- * Symbolic or mrg* variants for the operations in the base package + + -- ** mrg* variants for operations in "Control.Monad" + mrgReturnWithStrategy, + mrgBindWithStrategy, + mrgReturn, + (>>=~), + (>>~), + mrgFoldM, + mrgMzero, + mrgMplus, + mrgFmap, + + -- ** mrg* variants for operations in "Data.Foldable" + mrgFoldlM, + mrgFoldrM, + mrgTraverse_, + mrgFor_, + mrgMapM_, + mrgForM_, + mrgSequence_, + mrgMsum, + + -- ** mrg* variants for operations in "Data.Traversable" + mrgTraverse, + mrgSequenceA, + mrgFor, + mrgMapM, + mrgForM, + mrgSequence, + + -- ** Symbolic versions for operations in "Data.List" + (!!~), + symFilter, + symTake, + symDrop, + ) +where + +import Grisette.Lib.Control.Monad +import Grisette.Lib.Data.Foldable +import Grisette.Lib.Data.List +import Grisette.Lib.Data.Traversable diff --git a/src/Grisette/Lib/Control/Monad.hs b/src/Grisette/Lib/Control/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Monad.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Monad +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Control.Monad + ( -- * mrg* variants for operations in "Control.Monad" + mrgReturnWithStrategy, + mrgBindWithStrategy, + mrgReturn, + (>>=~), + (>>~), + mrgFoldM, + mrgMzero, + mrgMplus, + mrgFmap, + ) +where + +import Control.Monad +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Lib.Data.Foldable + +-- | 'return' with 'MergingStrategy' knowledge propagation. +mrgReturnWithStrategy :: (MonadUnion u) => MergingStrategy a -> a -> u a +mrgReturnWithStrategy s = mergeWithStrategy s . return +{-# INLINE mrgReturnWithStrategy #-} + +-- | '>>=' with 'MergingStrategy' knowledge propagation. +mrgBindWithStrategy :: (MonadUnion u) => MergingStrategy b -> u a -> (a -> u b) -> u b +mrgBindWithStrategy s a f = mergeWithStrategy s $ a >>= f +{-# INLINE mrgBindWithStrategy #-} + +-- | 'return' with 'MergingStrategy' knowledge propagation. +mrgReturn :: (MonadUnion u, Mergeable a) => a -> u a +mrgReturn = merge . return +{-# INLINE mrgReturn #-} + +-- | '>>=' with 'MergingStrategy' knowledge propagation. +(>>=~) :: (MonadUnion u, Mergeable b) => u a -> (a -> u b) -> u b +a >>=~ f = merge $ a >>= f +{-# INLINE (>>=~) #-} + +-- | 'foldM' with 'MergingStrategy' knowledge propagation. +mrgFoldM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b +mrgFoldM = mrgFoldlM +{-# INLINE mrgFoldM #-} + +-- | '>>' with 'MergingStrategy' knowledge propagation. +-- +-- This is usually more efficient than calling the original '>>' and merge the results. +(>>~) :: forall m a b. (MonadUnion m, Mergeable b) => m a -> m b -> m b +a >>~ f = merge $ mrgFmap (const ()) a >> f +{-# INLINE (>>~) #-} + +-- | 'mzero' with 'MergingStrategy' knowledge propagation. +mrgMzero :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a +mrgMzero = merge mzero +{-# INLINE mrgMzero #-} + +-- | 'mplus' with 'MergingStrategy' knowledge propagation. +mrgMplus :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -> m a -> m a +mrgMplus a b = merge $ mplus a b +{-# INLINE mrgMplus #-} + +-- | 'fmap' with 'MergingStrategy' knowledge propagation. +mrgFmap :: (MonadUnion f, Mergeable b, Functor f) => (a -> b) -> f a -> f b +mrgFmap f a = merge $ fmap f a +{-# INLINE mrgFmap #-} diff --git a/src/Grisette/Lib/Control/Monad.hs-boot b/src/Grisette/Lib/Control/Monad.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Monad.hs-boot @@ -0,0 +1,19 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +module Grisette.Lib.Control.Monad where + +import Control.Monad +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable + +mrgReturnWithStrategy :: (MonadUnion u) => MergingStrategy a -> a -> u a +mrgBindWithStrategy :: (MonadUnion u) => MergingStrategy b -> u a -> (a -> u b) -> u b +mrgReturn :: (MonadUnion u, Mergeable a) => a -> u a +(>>=~) :: (MonadUnion u, Mergeable b) => u a -> (a -> u b) -> u b +mrgFoldM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b +(>>~) :: forall m a b. (MonadUnion m, Mergeable b) => m a -> m b -> m b +mrgMzero :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a +mrgMplus :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -> m a -> m a +mrgFmap :: (MonadUnion f, Mergeable b, Functor f) => (a -> b) -> f a -> f b diff --git a/src/Grisette/Lib/Control/Monad/Except.hs b/src/Grisette/Lib/Control/Monad/Except.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Monad/Except.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Monad.Except +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Control.Monad.Except + ( -- * mrg* variants for operations in "Control.Monad.Except" + mrgThrowError, + mrgCatchError, + ) +where + +import Control.Monad.Except +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable + +-- | 'throwError' with 'MergingStrategy' knowledge propagation. +mrgThrowError :: (MonadError e m, MonadUnion m, Mergeable a) => e -> m a +mrgThrowError = merge . throwError +{-# INLINE mrgThrowError #-} + +-- | 'catchError' with 'MergingStrategy' knowledge propagation. +mrgCatchError :: + (MonadError e m, MonadUnion m, Mergeable a) => + m a -> + (e -> m a) -> + m a +mrgCatchError v handler = merge $ v `catchError` (merge . handler) +{-# INLINE mrgCatchError #-} diff --git a/src/Grisette/Lib/Control/Monad/Trans.hs b/src/Grisette/Lib/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Monad/Trans.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Monad.Trans +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Control.Monad.Trans + ( -- * mrg* variants for operations in "Control.Monad.Trans" + mrgLift, + ) +where + +import Control.Monad.Trans +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable + +-- | 'lift' with 'MergingStrategy' knowledge propagation. +mrgLift :: + forall t m a. + (MonadUnion (t m), MonadTrans t, Monad m, Mergeable a) => + m a -> + t m a +mrgLift v = merge $ lift v +{-# INLINE mrgLift #-} diff --git a/src/Grisette/Lib/Control/Monad/Trans/Cont.hs b/src/Grisette/Lib/Control/Monad/Trans/Cont.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Monad/Trans/Cont.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Monad.Trans.Cont +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Control.Monad.Trans.Cont + ( -- * mrg* variants for operations in "Control.Monad.Trans.Cont" + mrgRunContT, + mrgEvalContT, + mrgResetT, + ) +where + +import Control.Monad.Cont +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Lib.Control.Monad + +-- | 'Control.Monad.Cont.runContT' with 'MergingStrategy' knowledge propagation +mrgRunContT :: (UnionLike m, Mergeable r) => ContT r m a -> (a -> m r) -> m r +mrgRunContT c = merge . runContT c +{-# INLINE mrgRunContT #-} + +-- | 'Control.Monad.Cont.evalContT' with 'MergingStrategy' knowledge propagation +mrgEvalContT :: (UnionLike m, Mergeable r, Monad m) => ContT r m r -> m r +mrgEvalContT c = runContT c mrgReturn +{-# INLINE mrgEvalContT #-} + +-- | 'Control.Monad.Cont.resetT' with 'MergingStrategy' knowledge propagation +mrgResetT :: (UnionLike m, Mergeable r, Monad m) => Monad m => ContT r m r -> ContT r' m r +mrgResetT = lift . mrgEvalContT +{-# INLINE mrgResetT #-} diff --git a/src/Grisette/Lib/Data/Foldable.hs b/src/Grisette/Lib/Data/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Foldable.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Foldable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Data.Foldable + ( -- * mrg* variants for operations in "Data.Foldable" + mrgFoldlM, + mrgFoldrM, + mrgTraverse_, + mrgFor_, + mrgMapM_, + mrgForM_, + mrgSequence_, + mrgMsum, + ) +where + +import Control.Monad +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable +import {-# SOURCE #-} Grisette.Lib.Control.Monad + +-- | 'Data.Foldable.foldlM' with 'MergingStrategy' knowledge propagation. +mrgFoldlM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b +mrgFoldlM f z0 xs = foldr c mrgReturn xs z0 + where + c x k z = merge (f z x) >>= k +{-# INLINE mrgFoldlM #-} + +-- | 'Data.Foldable.foldrM' with 'MergingStrategy' knowledge propagation. +mrgFoldrM :: (MonadUnion m, Mergeable b, Foldable t) => (a -> b -> m b) -> b -> t a -> m b +mrgFoldrM f z0 xs = foldl c mrgReturn xs z0 + where + c k x z = merge (f x z) >>= k +{-# INLINE mrgFoldrM #-} + +-- | 'Data.Foldable.traverse_' with 'MergingStrategy' knowledge propagation. +mrgTraverse_ :: (MonadUnion m, Foldable t) => (a -> m b) -> t a -> m () +mrgTraverse_ f = foldr c (mrgReturn ()) + where + c x k = f x >> k +{-# INLINE mrgTraverse_ #-} + +-- | 'Data.Foldable.for_' with 'MergingStrategy' knowledge propagation. +mrgFor_ :: (MonadUnion m, Foldable t) => t a -> (a -> m b) -> m () +mrgFor_ = flip mrgTraverse_ +{-# INLINE mrgFor_ #-} + +-- | 'Data.Foldable.mapM_' with 'MergingStrategy' knowledge propagation. +mrgMapM_ :: (MonadUnion m, Foldable t) => (a -> m b) -> t a -> m () +mrgMapM_ = mrgTraverse_ +{-# INLINE mrgMapM_ #-} + +-- | 'Data.Foldable.forM_' with 'MergingStrategy' knowledge propagation. +mrgForM_ :: (MonadUnion m, Foldable t) => t a -> (a -> m b) -> m () +mrgForM_ = flip mrgMapM_ +{-# INLINE mrgForM_ #-} + +-- | 'Data.Foldable.sequence_' with 'MergingStrategy' knowledge propagation. +mrgSequence_ :: (Foldable t, MonadUnion m) => t (m a) -> m () +mrgSequence_ = foldr c (mrgReturn ()) + where + c m k = m >> k +{-# INLINE mrgSequence_ #-} + +-- | 'Data.Foldable.msum' with 'MergingStrategy' knowledge propagation. +mrgMsum :: forall m a t. (MonadUnion m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a +mrgMsum = foldr mrgMplus mrgMzero +{-# INLINE mrgMsum #-} diff --git a/src/Grisette/Lib/Data/List.hs b/src/Grisette/Lib/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/List.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Grisette.Lib.Data.List +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Data.List + ( -- * Symbolic versions of 'Data.List' operations + (!!~), + symFilter, + symTake, + symDrop, + ) +where + +import Control.Exception +import Control.Monad.Except +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Error +import Grisette.Core.Data.Class.Integer +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.IR.SymPrim.Data.SymPrim +import Grisette.Lib.Control.Monad + +-- | Symbolic version of 'Data.List.!!', the result would be merged and +-- propagate the mergeable knowledge. +(!!~) :: + ( MonadUnion uf, + MonadError e uf, + TransformError ArrayException e, + Mergeable a + ) => + [a] -> + SymInteger -> + uf a +l !!~ p = go l p 0 + where + go [] _ _ = throwError $ transformError (IndexOutOfBounds "!!~") + go (x : xs) p1 i = mrgIf (p1 ==~ i) (mrgReturn x) (go xs p1 $ i + 1) + +-- | Symbolic version of 'Data.List.filter', the result would be merged and +-- propagate the mergeable knowledge. +symFilter :: (MonadUnion u, Mergeable a) => (a -> SymBool) -> [a] -> u [a] +symFilter f = go + where + go [] = mrgReturn [] + go (x : xs) = do + r <- go xs + mrgIf (f x) (mrgReturn (x : r)) (mrgReturn r) + +-- | Symbolic version of 'Data.List.take', the result would be merged and +-- propagate the mergeable knowledge. +symTake :: (MonadUnion u, Mergeable a) => SymInteger -> [a] -> u [a] +symTake _ [] = mrgReturn [] +symTake x (v : vs) = mrgIf (x <=~ 0) (mrgReturn []) (mrgFmap (v :) $ symTake (x - 1) vs) + +-- | Symbolic version of 'Data.List.drop', the result would be merged and +-- propagate the mergeable knowledge. +symDrop :: (MonadUnion u, Mergeable a) => SymInteger -> [a] -> u [a] +symDrop _ [] = mrgReturn [] +symDrop x r@(_ : vs) = mrgIf (x <=~ 0) (mrgReturn r) (symDrop (x - 1) vs) diff --git a/src/Grisette/Lib/Data/Traversable.hs b/src/Grisette/Lib/Data/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Traversable.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Traversable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Data.Traversable + ( -- * mrg* variants for operations in "Data.Traversable" + mrgTraverse, + mrgSequenceA, + mrgFor, + mrgMapM, + mrgForM, + mrgSequence, + ) +where + +import Grisette.Core.Control.Monad.Union +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.SimpleMergeable + +-- | 'Data.Traversable.traverse' with 'MergingStrategy' knowledge propagation. +mrgTraverse :: + forall a b t f. + ( Mergeable b, + Mergeable1 t, + MonadUnion f, + Traversable t + ) => + (a -> f b) -> + t a -> + f (t b) +mrgTraverse f = mergeWithStrategy rootStrategy1 . traverse (merge . f) +{-# INLINE mrgTraverse #-} + +-- | 'Data.Traversable.sequenceA' with 'MergingStrategy' knowledge propagation. +mrgSequenceA :: + forall a t f. + ( Mergeable a, + Mergeable1 t, + MonadUnion f, + Traversable t + ) => + t (f a) -> + f (t a) +mrgSequenceA = mrgTraverse id +{-# INLINE mrgSequenceA #-} + +-- | 'Data.Traversable.mapM' with 'MergingStrategy' knowledge propagation. +mrgMapM :: + forall a b t f. + ( Mergeable b, + Mergeable1 t, + MonadUnion f, + Traversable t + ) => + (a -> f b) -> + t a -> + f (t b) +mrgMapM = mrgTraverse +{-# INLINE mrgMapM #-} + +-- | 'Data.Traversable.sequence' with 'MergingStrategy' knowledge propagation. +mrgSequence :: + forall a t f. + ( Mergeable a, + Mergeable1 t, + MonadUnion f, + Traversable t + ) => + t (f a) -> + f (t a) +mrgSequence = mrgSequenceA +{-# INLINE mrgSequence #-} + +-- | 'Data.Traversable.for' with 'MergingStrategy' knowledge propagation. +mrgFor :: + ( Mergeable b, + Mergeable1 t, + Traversable t, + MonadUnion m + ) => + t a -> + (a -> m b) -> + m (t b) +mrgFor = flip mrgTraverse +{-# INLINE mrgFor #-} + +-- | 'Data.Traversable.forM' with 'MergingStrategy' knowledge propagation. +mrgForM :: + ( Mergeable b, + Mergeable1 t, + Traversable t, + MonadUnion m + ) => + t a -> + (a -> m b) -> + m (t b) +mrgForM = flip mrgMapM +{-# INLINE mrgForM #-} diff --git a/src/Grisette/Lib/Mtl.hs b/src/Grisette/Lib/Mtl.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Mtl.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Mtl +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Mtl + ( -- * Symbolic or mrg* variants for the operations in the mtl (and transformers) package + + -- ** mrg* variants for operations in "Control.Monad.Except" + mrgThrowError, + mrgCatchError, + + -- ** mrg* variants for operations in "Control.Monad.Trans" + mrgLift, + + -- ** mrg* variants for operations in "Control.Monad.Trans.Cont" + mrgRunContT, + mrgEvalContT, + mrgResetT, + ) +where + +import Grisette.Lib.Control.Monad.Except +import Grisette.Lib.Control.Monad.Trans +import Grisette.Lib.Control.Monad.Trans.Cont diff --git a/test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs b/test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Backend.SBV.Data.SMT.CEGISTests where + +import Control.Monad.Except +import qualified Data.HashSet as S +import Data.Proxy +import qualified Data.SBV as SBV +import Grisette.Backend.SBV.Data.SMT.Solving +import Grisette.Core.Control.Exception +import Grisette.Core.Control.Monad.UnionM +import Grisette.Core.Data.Class.BitVector +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.CEGISSolver +import Grisette.Core.Data.Class.Error +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.Solver +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.Model +import Grisette.IR.SymPrim.Data.SymPrim +import Test.Tasty +import Test.Tasty.HUnit + +testCegis :: (HasCallStack, ExtractSymbolics a, EvaluateSym a, Show a) => GrisetteSMTConfig i -> Bool -> a -> [SymBool] -> Assertion +testCegis config shouldSuccess a bs = do + x <- cegisExceptVC config (a, ssym "internal" :: SymInteger) return (runExceptT $ buildFormula bs) + case x of + Left _ -> shouldSuccess @=? False + Right (_, m) -> do + shouldSuccess @=? True + verify bs + where + verify [] = return () + verify (v : vs) = do + y <- solve config (evaluateSym False m $ nots v) + case y of + Left _ -> do + verify vs + Right _ -> assertFailure $ "Failed to verify " ++ show v ++ " with the model " ++ show m + where + buildFormula :: [SymBool] -> ExceptT VerificationConditions UnionM () + buildFormula l = do + symAssume ((ssym "internal" :: SymInteger) >=~ 0) + go l 0 + where + go :: [SymBool] -> SymInteger -> ExceptT VerificationConditions UnionM () + go [] _ = return () + go (x : xs) i = + mrgIf + (ssym "internal" >=~ i &&~ ssym "internal" <~ (i + 1)) + (symAssert x) + (go xs (i + 1)) + +cegisTests :: TestTree +cegisTests = + let unboundedConfig = UnboundedReasoning SBV.z3 -- {SBV.verbose=True} + in testGroup + "CEGISTests" + [ testGroup + "Boolean" + [ testCase "Basic" $ do + testCegis + unboundedConfig + True + () + [ssym "a", ssym "b", ssym "c"] + testCegis + unboundedConfig + False + () + [ssym "a", nots $ ssym "a"], + testCase "And" $ do + testCegis + unboundedConfig + True + () + [ssym "a" &&~ ssym "b", ssym "b" &&~ nots (ssym "c"), ssym "a", ssym "b", nots (ssym "c")] + testCegis + unboundedConfig + False + () + [ssym "a" &&~ ssym "b", ssym "b" &&~ nots (ssym "c"), ssym "a", ssym "b", ssym "c"] + testCegis + unboundedConfig + True + (ssym "a" :: SymBool) + [nots $ ssym "a" &&~ ssym "b", nots $ ssym "b"] + testCegis + unboundedConfig + False + (ssym "a" :: SymBool) + [nots $ ssym "a" &&~ ssym "b", ssym "b"], + testCase "Or" $ do + testCegis + unboundedConfig + True + () + [ssym "a" ||~ ssym "b", ssym "b" ||~ nots (ssym "c"), ssym "a", ssym "b", nots (ssym "c")] + testCegis + unboundedConfig + True + () + [ssym "a" ||~ ssym "b", ssym "b" ||~ nots (ssym "c"), ssym "a", ssym "b", ssym "c"] + testCegis + unboundedConfig + True + (ssym "a" :: SymBool) + [ssym "a" ||~ ssym "b", ssym "b"] + testCegis + unboundedConfig + False + (ssym "a" :: SymBool) + [ssym "a" ||~ ssym "b", nots $ ssym "b"], + testCase "And / Or should be consistent" $ do + testCegis + unboundedConfig + True + () + [ssym "a" &&~ ssym "b", ssym "a" ||~ ssym "b"] + testCegis + unboundedConfig + True + () + [nots $ ssym "a" &&~ ssym "b", ssym "a" ||~ ssym "b"] + testCegis + unboundedConfig + False + () + [ssym "a" &&~ ssym "b", nots $ ssym "a" ||~ ssym "b"] + testCegis + unboundedConfig + True + () + [nots $ ssym "a" &&~ ssym "b", nots $ ssym "a" ||~ ssym "b"], + testCase "Eqv" $ do + testCegis + unboundedConfig + True + () + [(ssym "a" :: SymBool) ==~ ssym "b", ssym "a", ssym "b"] + testCegis + unboundedConfig + True + () + [(ssym "a" :: SymBool) ==~ ssym "b", nots $ ssym "a", nots $ ssym "b"] + testCegis + unboundedConfig + False + () + [(ssym "a" :: SymBool) ==~ ssym "b", nots $ ssym "a", ssym "b"] + testCegis + unboundedConfig + False + () + [(ssym "a" :: SymBool) ==~ ssym "b", nots $ ssym "a", ssym "b"] + testCegis + unboundedConfig + True + () + [(ssym "a" :: SymBool) ==~ ssym "b", nots (ssym "a") `xors` ssym "b"] + testCegis + unboundedConfig + False + () + [(ssym "a" :: SymBool) ==~ ssym "b", ssym "a" `xors` ssym "b"], + testCase "ites" $ do + testCegis + unboundedConfig + True + (ssym "c" :: SymBool) + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), ssym "a", ssym "b"] + testCegis + unboundedConfig + False + (ssym "c" :: SymBool) + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), nots $ ssym "a"] + testCegis + unboundedConfig + True + (ssym "b" :: SymBool) + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), nots $ ssym "a", ssym "c"] + testCegis + unboundedConfig + False + (ssym "b" :: SymBool) + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), ssym "a"] + testCegis + unboundedConfig + True + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), ssym "a", ssym "b", ssym "c"] + testCegis + unboundedConfig + True + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), ssym "a", ssym "b", nots $ ssym "c"] + testCegis + unboundedConfig + True + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), nots $ ssym "a", ssym "b", ssym "c"] + testCegis + unboundedConfig + True + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), nots $ ssym "a", nots $ ssym "b", ssym "c"] + testCegis + unboundedConfig + False + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), ssym "a", nots $ ssym "b", ssym "c"] + testCegis + unboundedConfig + False + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), ssym "a", nots $ ssym "b", nots $ ssym "c"] + testCegis + unboundedConfig + False + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), nots $ ssym "a", ssym "b", nots $ ssym "c"] + testCegis + unboundedConfig + False + () + [ites (ssym "a" :: SymBool) (ssym "b") (ssym "c"), nots $ ssym "a", nots $ ssym "b", nots $ ssym "c"] + ], + let a = ssym "a" :: SymIntN 5 + b = ssym "b" :: SymIntN 5 + c = ssym "c" :: SymIntN 5 + d = ssym "c" :: SymIntN 10 + in testGroup + "Different sized BV" + [ testGroup + "Extract" + [ testCase "Extract" $ do + testCegis + unboundedConfig + True + () + [bvselect (Proxy @2) (Proxy @2) a ==~ (con 1 :: SymIntN 2), a ==~ con 0b10101] + testCegis + unboundedConfig + False + () + [bvselect (Proxy @2) (Proxy @2) a ==~ (con 1 :: SymIntN 2), a ==~ con 0b10001], + testCase "Extract when lowered twice" $ do + testCegis + unboundedConfig + True + a + [bvselect (Proxy @2) (Proxy @2) (bvconcat a b) ==~ (con 1 :: SymIntN 2)] + testCegis + unboundedConfig + True + b + [bvselect (Proxy @7) (Proxy @2) (bvconcat a b) ==~ (con 1 :: SymIntN 2)] + ], + testGroup + "Concat" + [ testCase "Concat" $ do + testCegis + unboundedConfig + True + () + [bvconcat a b ==~ d, a ==~ con 1, b ==~ con 1, d ==~ con 0b100001] + testCegis + unboundedConfig + False + () + [bvconcat a b ==~ d, a ==~ con 1, b ==~ con 1, d ==~ con 0b100010], + testCase "Concat when lowered twice" $ do + testCegis + unboundedConfig + True + (a, c) + [bvconcat c (bvselect (Proxy @2) (Proxy @2) (bvconcat a b) :: SymIntN 2) ==~ bvconcat c (con 1 :: SymIntN 2)] + testCegis + unboundedConfig + True + (b, c) + [bvconcat c (bvselect (Proxy @7) (Proxy @2) (bvconcat a b) :: SymIntN 2) ==~ bvconcat c (con 1 :: SymIntN 2)] + ], + testGroup + "Zext" + [ testCase "bvzeroExtend" $ do + testCegis + unboundedConfig + True + () + [bvzeroExtend (Proxy @10) a ==~ d, a ==~ con 1, d ==~ (con 1 :: SymIntN 10)] + testCegis + unboundedConfig + True + () + [bvzeroExtend (Proxy @10) a ==~ d, a ==~ con 0b11111, d ==~ (con 0b11111 :: SymIntN 10)] + testCegis + unboundedConfig + False + () + [bvzeroExtend (Proxy @10) a ==~ d, d ==~ (con 0b111111 :: SymIntN 10)] + testCegis + unboundedConfig + False + () + [bvzeroExtend (Proxy @10) a ==~ d, d ==~ (con 0b1111111111 :: SymIntN 10)], + testCase "bvzeroExtend when lowered twice" $ do + testCegis + unboundedConfig + True + a + [bvzeroExtend (Proxy @10) (bvselect (Proxy @2) (Proxy @2) (bvconcat a b) :: SymIntN 2) ==~ (con 1 :: SymIntN 10)] + testCegis + unboundedConfig + True + b + [bvzeroExtend (Proxy @10) (bvselect (Proxy @7) (Proxy @2) (bvconcat a b) :: SymIntN 2) ==~ (con 1 :: SymIntN 10)] + ], + testGroup + "Sext" + [ testCase "bvsignExtend" $ do + testCegis + unboundedConfig + True + () + [bvsignExtend (Proxy @10) a ==~ d, a ==~ con 1, d ==~ (con 1 :: SymIntN 10)] + testCegis + unboundedConfig + True + () + [bvsignExtend (Proxy @10) a ==~ d, a ==~ con 0b11111, d ==~ (con 0b1111111111 :: SymIntN 10)] + testCegis + unboundedConfig + False + () + [bvsignExtend (Proxy @10) a ==~ d, d ==~ (con 0b111111 :: SymIntN 10)] + testCegis + unboundedConfig + False + () + [bvsignExtend (Proxy @10) a ==~ d, d ==~ (con 0b11111 :: SymIntN 10)], + testCase "bvsignExtend when lowered twice" $ do + testCegis + unboundedConfig + True + a + [bvsignExtend (Proxy @10) (bvselect (Proxy @2) (Proxy @2) (bvconcat a b) :: SymIntN 2) ==~ (con 1 :: SymIntN 10)] + testCegis + unboundedConfig + True + b + [bvsignExtend (Proxy @10) (bvselect (Proxy @7) (Proxy @2) (bvconcat a b) :: SymIntN 2) ==~ (con 1 :: SymIntN 10)] + ] + ] + ] diff --git a/test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs b/test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Backend.SBV.Data.SMT.LoweringTests where + +import Control.Monad.Trans +import Data.Bits +import Data.Dynamic +import qualified Data.HashMap.Strict as M +import Data.Proxy +import qualified Data.SBV as SBV +import qualified Data.SBV.Control as SBV +import Grisette.Backend.SBV.Data.SMT.Lowering +import Grisette.Backend.SBV.Data.SMT.Solving +import Grisette.Backend.SBV.Data.SMT.SymBiMap +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Test.Tasty +import Test.Tasty.HUnit + +testUnaryOpLowering :: + forall a b as n. + ( HasCallStack, + SupportedPrim a, + SBV.EqSymbolic (TermTy n b), + Typeable (TermTy n a), + SBV.SymVal as, + TermTy n a ~ SBV.SBV as, + Show as + ) => + GrisetteSMTConfig n -> + (Term a -> Term b) -> + String -> + (TermTy n a -> TermTy n b) -> + Assertion +testUnaryOpLowering config f name sbvfun = do + let a :: Term a = ssymTerm "a" + let fa :: Term b = f a + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fa + let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + case sbva of + Nothing -> lift $ assertFailure "Failed to extract the term" + Just sbvav -> SBV.query $ do + SBV.constrain $ lt SBV..== sbvfun sbvav + satres <- SBV.checkSat + case satres of + SBV.Sat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fa + let sbvv :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + case sbvv of + Nothing -> lift $ assertFailure "Failed to extract the term" + Just sbvvv -> SBV.query $ do + SBV.constrain $ lt SBV../= sbvfun sbvvv + r <- SBV.checkSat + case r of + SBV.Sat -> do + counterExample <- SBV.getValue sbvvv + lift $ assertFailure $ "Translation counter example found: " ++ show counterExample + SBV.Unsat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" + +testUnaryOpLowering' :: + forall a b as n tag. + ( HasCallStack, + UnaryOp tag a b, + SBV.EqSymbolic (TermTy n b), + Typeable (TermTy n a), + SBV.SymVal as, + TermTy n a ~ SBV.SBV as, + Show as + ) => + GrisetteSMTConfig n -> + tag -> + (TermTy n a -> TermTy n b) -> + Assertion +testUnaryOpLowering' config t = testUnaryOpLowering @a @b @as config (constructUnary t) (show t) + +testBinaryOpLowering :: + forall a b c as bs n. + ( HasCallStack, + SupportedPrim a, + SupportedPrim b, + SBV.EqSymbolic (TermTy n c), + Typeable (TermTy n a), + Typeable (TermTy n b), + SBV.SymVal as, + SBV.SymVal bs, + Show as, + Show bs, + TermTy n a ~ SBV.SBV as, + TermTy n b ~ SBV.SBV bs + ) => + GrisetteSMTConfig n -> + (Term a -> Term b -> Term c) -> + String -> + (TermTy n a -> TermTy n b -> TermTy n c) -> + Assertion +testBinaryOpLowering config f name sbvfun = do + let a :: Term a = ssymTerm "a" + let b :: Term b = ssymTerm "b" + let fab :: Term c = f a b + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fab + let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb) of + (Just sbvav, Just sbvbv) -> SBV.query $ do + SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv + satres <- SBV.checkSat + case satres of + SBV.Sat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" + _ -> lift $ assertFailure "Failed to extract the term" + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fab + let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb) of + (Just sbvav, Just sbvbv) -> SBV.query $ do + SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv + r <- SBV.checkSat + case r of + SBV.Sat -> do + counterExampleA <- SBV.getValue sbvav + counterExampleB <- SBV.getValue sbvbv + lift $ assertFailure $ "Translation counter example found: " ++ show (counterExampleA, counterExampleB) + SBV.Unsat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" + _ -> lift $ assertFailure "Failed to extract the term" + +testBinaryOpLowering' :: + forall a b c as bs n tag. + ( HasCallStack, + BinaryOp tag a b c, + SBV.EqSymbolic (TermTy n c), + Typeable (TermTy n a), + Typeable (TermTy n b), + SBV.SymVal as, + SBV.SymVal bs, + Show as, + Show bs, + TermTy n a ~ SBV.SBV as, + TermTy n b ~ SBV.SBV bs + ) => + GrisetteSMTConfig n -> + tag -> + (TermTy n a -> TermTy n b -> TermTy n c) -> + Assertion +testBinaryOpLowering' config t = testBinaryOpLowering @a @b @c @as @bs config (constructBinary t) (show t) + +testTernaryOpLowering :: + forall a b c d as bs cs n. + ( HasCallStack, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SBV.EqSymbolic (TermTy n d), + Typeable (TermTy n a), + Typeable (TermTy n b), + Typeable (TermTy n c), + SBV.SymVal as, + SBV.SymVal bs, + SBV.SymVal cs, + Show as, + Show bs, + Show cs, + TermTy n a ~ SBV.SBV as, + TermTy n b ~ SBV.SBV bs, + TermTy n c ~ SBV.SBV cs + ) => + GrisetteSMTConfig n -> + (Term a -> Term b -> Term c -> Term d) -> + String -> + (TermTy n a -> TermTy n b -> TermTy n c -> TermTy n d) -> + Assertion +testTernaryOpLowering config f name sbvfun = do + let a :: Term a = ssymTerm "a" + let b :: Term b = ssymTerm "b" + let c :: Term c = ssymTerm "c" + let fabc :: Term d = f a b c + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fabc + let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + let sbvc :: Maybe (TermTy n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb, sbvc) of + (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do + SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv sbvcv + satres <- SBV.checkSat + case satres of + SBV.Sat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" + _ -> lift $ assertFailure "Failed to extract the term" + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fabc + let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + let sbvc :: Maybe (TermTy n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb, sbvc) of + (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do + SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv sbvcv + r <- SBV.checkSat + case r of + SBV.Sat -> do + counterExampleA <- SBV.getValue sbvav + counterExampleB <- SBV.getValue sbvbv + counterExampleC <- SBV.getValue sbvcv + lift $ + assertFailure $ + "Translation counter example found: " + ++ show (counterExampleA, counterExampleB, counterExampleC) + SBV.Unsat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" + _ -> lift $ assertFailure "Failed to extract the term" + +testTernaryOpLowering' :: + forall a b c d as bs cs n tag. + ( HasCallStack, + TernaryOp tag a b c d, + SBV.EqSymbolic (TermTy n d), + Typeable (TermTy n a), + Typeable (TermTy n b), + Typeable (TermTy n c), + SBV.SymVal as, + SBV.SymVal bs, + SBV.SymVal cs, + Show as, + Show bs, + Show cs, + TermTy n a ~ SBV.SBV as, + TermTy n b ~ SBV.SBV bs, + TermTy n c ~ SBV.SBV cs + ) => + GrisetteSMTConfig n -> + tag -> + (TermTy n a -> TermTy n b -> TermTy n c -> TermTy n d) -> + Assertion +testTernaryOpLowering' config t = testTernaryOpLowering @a @b @c @d @as @bs @cs config (constructTernary t) (show t) + +loweringTests :: TestTree +loweringTests = + let unboundedConfig = UnboundedReasoning SBV.z3 + boundedConfig = BoundedReasoning @5 SBV.z3 + in testGroup + "LoweringTests" + [ testGroup + "Bool Lowering" + [ testCase "Not" $ do + testUnaryOpLowering @Bool @Bool unboundedConfig notTerm "not" SBV.sNot, + testCase "And" $ do + testBinaryOpLowering @Bool @Bool @Bool unboundedConfig andTerm "and" (SBV..&&) + testBinaryOpLowering @Bool @Bool @Bool + unboundedConfig + andTerm + "and" + (\x y -> SBV.sNot (x SBV..<+> y) SBV..&& (x SBV..|| y)), + testCase "Or" $ do + testBinaryOpLowering @Bool @Bool @Bool unboundedConfig orTerm "or" (SBV..||) + testBinaryOpLowering @Bool @Bool @Bool + unboundedConfig + orTerm + "or" + (\x y -> (x SBV..<+> y) SBV..|| (x SBV..&& y)), + testCase "Eqv" $ do + testBinaryOpLowering @Bool @Bool @Bool unboundedConfig eqvTerm "eqv" (SBV..==) + testBinaryOpLowering @Bool @Bool @Bool + unboundedConfig + eqvTerm + "eqv" + (\x y -> SBV.sNot (x SBV..<+> y)), + testCase "ITE" $ do + testTernaryOpLowering @Bool @Bool @Bool @Bool unboundedConfig iteTerm "ite" SBV.ite + testTernaryOpLowering @Bool @Bool @Bool @Bool + unboundedConfig + iteTerm + "ite" + (\c x y -> (c SBV..=> x) SBV..&& (SBV.sNot c SBV..=> y)) + ], + testGroup + "Integer Lowering" + [ testCase "Add" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @Integer @Integer @Integer + unboundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1) + testBinaryOpLowering @Integer @Integer @Integer boundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @Integer @Integer @Integer + boundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1), + testCase "Uminus" $ do + testUnaryOpLowering @Integer @Integer unboundedConfig uminusNumTerm "negate" negate + testUnaryOpLowering @Integer @Integer + unboundedConfig + uminusNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1) + testUnaryOpLowering @Integer @Integer boundedConfig uminusNumTerm "negate" negate + testUnaryOpLowering @Integer @Integer + boundedConfig + uminusNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), + testCase "Abs" $ do + testUnaryOpLowering @Integer @Integer unboundedConfig absNumTerm "abs" abs + testUnaryOpLowering @Integer @Integer boundedConfig absNumTerm "abs" abs, + testCase "Signum" $ do + testUnaryOpLowering @Integer @Integer unboundedConfig signumNumTerm "signum" signum + testUnaryOpLowering @Integer @Integer boundedConfig signumNumTerm "signum" signum, + testCase "Times" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig timesNumTerm "(*)" (*) + testBinaryOpLowering @Integer @Integer @Integer + unboundedConfig + timesNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1) + testBinaryOpLowering @Integer @Integer @Integer boundedConfig timesNumTerm "(*)" (*) + testBinaryOpLowering @Integer @Integer @Integer + boundedConfig + timesNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1), + testCase "Lt" $ do + testBinaryOpLowering @Integer @Integer @Bool unboundedConfig ltNumTerm "(<)" (SBV..<) + testBinaryOpLowering @Integer @Integer @Bool + unboundedConfig + ltNumTerm + "(<)" + (\x y -> x * 2 - x SBV..< y * 2 - y) + testBinaryOpLowering @Integer @Integer @Bool boundedConfig ltNumTerm "(<)" (SBV..<) + testBinaryOpLowering @Integer @Integer @Bool + boundedConfig + ltNumTerm + "(<=)" + (\x y -> x * 2 - x SBV..< y * 2 - y), + testCase "Le" $ do + testBinaryOpLowering @Integer @Integer @Bool unboundedConfig leNumTerm "(<=)" (SBV..<=) + testBinaryOpLowering @Integer @Integer @Bool + unboundedConfig + leNumTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y) + testBinaryOpLowering @Integer @Integer @Bool boundedConfig leNumTerm "(<=)" (SBV..<=) + testBinaryOpLowering @Integer @Integer @Bool + boundedConfig + leNumTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y), + testCase "DivI" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig divIntegerTerm "div" SBV.sDiv + testBinaryOpLowering @Integer @Integer @Integer boundedConfig divIntegerTerm "div" SBV.sDiv, + testCase "ModI" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig modIntegerTerm "mod" SBV.sMod + testBinaryOpLowering @Integer @Integer @Integer boundedConfig modIntegerTerm "mod" SBV.sMod + ], + testGroup + "IntN Lowering" + [ testCase "Add" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1), + testCase "Uminus" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig uminusNumTerm "negate" negate + testUnaryOpLowering @(IntN 5) + unboundedConfig + uminusNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), + testCase "Abs" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig absNumTerm "abs" abs, + testCase "Signum" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig signumNumTerm "signum" signum, + testCase "Times" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig timesNumTerm "(*)" (*) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + timesNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1), + testCase "Lt" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig ltNumTerm "(<)" (SBV..<) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + ltNumTerm + "(<)" + (\x y -> x * 2 - x SBV..< y * 2 - y), + testCase "Le" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig leNumTerm "(<=)" (SBV..<=) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + leNumTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y), + testCase "Extract" $ do + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @1)) + "select" + (SBV.bvExtract @0 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @1)) + "select" + (SBV.bvExtract @1 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @1)) + "select" + (SBV.bvExtract @2 @2 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @1)) + "select" + (SBV.bvExtract @3 @3 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @4) (Proxy @1)) + "select" + (SBV.bvExtract @4 @4 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @2)) + "select" + (SBV.bvExtract @1 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @2)) + "select" + (SBV.bvExtract @2 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @2)) + "select" + (SBV.bvExtract @3 @2 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @2)) + "select" + (SBV.bvExtract @4 @3 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 3) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @3)) + "select" + (SBV.bvExtract @2 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 3) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @3)) + "select" + (SBV.bvExtract @3 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 3) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @3)) + "select" + (SBV.bvExtract @4 @2 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 4) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @4)) + "select" + (SBV.bvExtract @3 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 4) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @4)) + "select" + (SBV.bvExtract @4 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @5)) + "select" + id, + testCase "Extension" $ do + testUnaryOpLowering @(IntN 5) @(IntN 6) + unboundedConfig + (bvzeroExtendTerm (Proxy @6)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(IntN 5) @(IntN 10) + unboundedConfig + (bvzeroExtendTerm (Proxy @10)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(IntN 5) @(IntN 6) + unboundedConfig + (bvsignExtendTerm (Proxy @6)) + "bvsignExtend" + SBV.signExtend + testUnaryOpLowering @(IntN 5) @(IntN 10) + unboundedConfig + (bvsignExtendTerm (Proxy @10)) + "bvsignExtend" + SBV.signExtend, + testCase "Concat" $ do + testBinaryOpLowering @(IntN 4) @(IntN 5) @(IntN 9) + unboundedConfig + bvconcatTerm + "bvconcat" + (SBV.#), + testCase "AndBits" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig andBitsTerm "(.&.)" (.&.), + testCase "OrBits" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig orBitsTerm "(.|.)" (.|.), + testCase "XorBits" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig xorBitsTerm "xor" xor, + testCase "ComplementBits" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig complementBitsTerm "complement" complement, + testCase "ShiftBits" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 0) "shift" id + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 1) "shift" (`shift` 1) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 2) "shift" (`shift` 2) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 3) "shift" (`shift` 3) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 4) "shift" (`shift` 4) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 5) "shift" (`shift` 5) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` 5) "shift" (const 0) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` (-1)) "shift" (`shift` (-1)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` (-2)) "shift" (`shift` (-2)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` (-3)) "shift" (`shift` (-3)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` (-4)) "shift" (`shift` (-4)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`shiftBitsTerm` (-5)) "shift" (`shift` (-5)) + testUnaryOpLowering @(IntN 5) + unboundedConfig + (`shiftBitsTerm` (-5)) + "shift" + (\x -> SBV.ite (x SBV..>= 0) 0 (-1)), + testCase "RotateBits" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 0) "rotate" id + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 1) "rotate" (`rotate` 1) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 2) "rotate" (`rotate` 2) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 3) "rotate" (`rotate` 3) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 4) "rotate" (`rotate` 4) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 5) "rotate" (`rotate` 5) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` 5) "rotate" id + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-1)) "rotate" (`rotate` (-1)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-1)) "rotate" (`rotate` 4) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-2)) "rotate" (`rotate` (-2)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-2)) "rotate" (`rotate` 3) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-3)) "rotate" (`rotate` (-3)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-3)) "rotate" (`rotate` 2) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-4)) "rotate" (`rotate` (-4)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-4)) "rotate" (`rotate` 1) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-5)) "rotate" (`rotate` (-5)) + testUnaryOpLowering @(IntN 5) unboundedConfig (`rotateBitsTerm` (-5)) "rotate" id + ], + testGroup + "WordN" + [ testCase "Add" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1), + testCase "Uminus" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig uminusNumTerm "negate" negate + testUnaryOpLowering @(WordN 5) + unboundedConfig + uminusNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), + testCase "Abs" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig absNumTerm "abs" abs, + testCase "Signum" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig signumNumTerm "signum" signum, + testCase "Times" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig timesNumTerm "(*)" (*) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + timesNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1), + testCase "Lt" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig ltNumTerm "(<)" (SBV..<) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + ltNumTerm + "(<)" + (\x y -> x * 2 - x SBV..< y * 2 - y), + testCase "Le" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig leNumTerm "(<=)" (SBV..<=) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + leNumTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y), + testCase "Extract" $ do + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @1)) + "select" + (SBV.bvExtract @0 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @1)) + "select" + (SBV.bvExtract @1 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @1)) + "select" + (SBV.bvExtract @2 @2 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @1)) + "select" + (SBV.bvExtract @3 @3 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @4) (Proxy @1)) + "select" + (SBV.bvExtract @4 @4 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @2)) + "select" + (SBV.bvExtract @1 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @2)) + "select" + (SBV.bvExtract @2 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @2)) + "select" + (SBV.bvExtract @3 @2 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @2)) + "select" + (SBV.bvExtract @4 @3 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 3) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @3)) + "select" + (SBV.bvExtract @2 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 3) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @3)) + "select" + (SBV.bvExtract @3 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 3) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @3)) + "select" + (SBV.bvExtract @4 @2 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 4) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @4)) + "select" + (SBV.bvExtract @3 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 4) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @4)) + "select" + (SBV.bvExtract @4 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @5)) + "select" + id, + testCase "Extension" $ do + testUnaryOpLowering @(WordN 5) @(WordN 6) + unboundedConfig + (bvzeroExtendTerm (Proxy @6)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(WordN 5) @(WordN 10) + unboundedConfig + (bvzeroExtendTerm (Proxy @10)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(WordN 5) @(WordN 6) + unboundedConfig + (bvsignExtendTerm (Proxy @6)) + "bvsignExtend" + SBV.signExtend + testUnaryOpLowering @(WordN 5) @(WordN 10) + unboundedConfig + (bvsignExtendTerm (Proxy @10)) + "bvsignExtend" + SBV.signExtend, + testCase "Concat" $ do + testBinaryOpLowering @(WordN 4) @(WordN 5) @(WordN 9) + unboundedConfig + bvconcatTerm + "bvconcat" + (SBV.#), + testCase "AndBits" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig andBitsTerm "(.&.)" (.&.), + testCase "OrBits" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig orBitsTerm "(.|.)" (.|.), + testCase "XorBits" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig xorBitsTerm "xor" xor, + testCase "ComplementBits" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig complementBitsTerm "complement" complement, + testCase "ShiftBits" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 0) "shift" id + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 1) "shift" (`shift` 1) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 2) "shift" (`shift` 2) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 3) "shift" (`shift` 3) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 4) "shift" (`shift` 4) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 5) "shift" (`shift` 5) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` 5) "shift" (const 0) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` (-1)) "shift" (`shift` (-1)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` (-2)) "shift" (`shift` (-2)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` (-3)) "shift" (`shift` (-3)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` (-4)) "shift" (`shift` (-4)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`shiftBitsTerm` (-5)) "shift" (`shift` (-5)) + testUnaryOpLowering @(WordN 5) + unboundedConfig + (`shiftBitsTerm` (-5)) + "shift" + (\x -> SBV.ite (x SBV..>= 0) 0 (-1)), + testCase "RotateBits" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 0) "rotate" id + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 1) "rotate" (`rotate` 1) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 2) "rotate" (`rotate` 2) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 3) "rotate" (`rotate` 3) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 4) "rotate" (`rotate` 4) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 5) "rotate" (`rotate` 5) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` 5) "rotate" id + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-1)) "rotate" (`rotate` (-1)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-1)) "rotate" (`rotate` 4) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-2)) "rotate" (`rotate` (-2)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-2)) "rotate" (`rotate` 3) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-3)) "rotate" (`rotate` (-3)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-3)) "rotate" (`rotate` 2) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-4)) "rotate" (`rotate` (-4)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-4)) "rotate" (`rotate` 1) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-5)) "rotate" (`rotate` (-5)) + testUnaryOpLowering @(WordN 5) unboundedConfig (`rotateBitsTerm` (-5)) "rotate" id + ] + ] diff --git a/test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs b/test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs @@ -0,0 +1,825 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Backend.SBV.Data.SMT.TermRewritingGen where + +import Data.Bits +import Data.Data +import Data.Kind +import GHC.TypeLits +import Grisette.Core.Data.Class.BitVector +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Test.Tasty.QuickCheck + +class (SupportedPrim b) => TermRewritingSpec a b | a -> b where + norewriteVer :: a -> Term b + rewriteVer :: a -> Term b + wrap :: Term b -> Term b -> a + same :: a -> Term Bool + counterExample :: a -> Term Bool + counterExample = notTerm . same + symSpec :: String -> a + symSpec s = wrap (ssymTerm s) (ssymTerm s) + conSpec :: b -> a + conSpec v = wrap (conTerm v) (conTerm v) + +constructUnarySpec :: + forall a av b bv. + ( TermRewritingSpec a av, + TermRewritingSpec b bv + ) => + (Term av -> Term bv) -> + (Term av -> Term bv) -> + a -> + b +constructUnarySpec construct partial a = + wrap (construct $ norewriteVer a) (partial $ rewriteVer a) + +constructUnarySpec' :: + forall a av b bv tag. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + UnaryOp tag av bv + ) => + tag -> + a -> + b +constructUnarySpec' tag = constructUnarySpec @a @av @b @bv (constructUnary tag) (partialEvalUnary tag) + +constructBinarySpec :: + forall a av b bv c cv. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv + ) => + (Term av -> Term bv -> Term cv) -> + (Term av -> Term bv -> Term cv) -> + a -> + b -> + c +constructBinarySpec construct partial a b = + wrap + (construct (norewriteVer a) (norewriteVer b)) + (partial (rewriteVer a) (rewriteVer b)) + +constructBinarySpec' :: + forall a av b bv c cv tag. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv, + BinaryOp tag av bv cv + ) => + tag -> + a -> + b -> + c +constructBinarySpec' tag = constructBinarySpec @a @av @b @bv @c @cv (constructBinary tag) (partialEvalBinary tag) + +constructTernarySpec :: + forall a av b bv c cv d dv. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv, + TermRewritingSpec d dv + ) => + (Term av -> Term bv -> Term cv -> Term dv) -> + (Term av -> Term bv -> Term cv -> Term dv) -> + a -> + b -> + c -> + d +constructTernarySpec construct partial a b c = + wrap + (construct (norewriteVer a) (norewriteVer b) (norewriteVer c)) + (partial (rewriteVer a) (rewriteVer b) (rewriteVer c)) + +constructTernarySpec' :: + forall a av b bv c cv d dv tag. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv, + TermRewritingSpec d dv, + TernaryOp tag av bv cv dv + ) => + tag -> + a -> + b -> + c -> + d +constructTernarySpec' tag = + constructTernarySpec @a @av @b @bv @c @cv @d @dv + (constructTernary tag) + (partialEvalTernary tag) + +notSpec :: (TermRewritingSpec a Bool) => a -> a +notSpec = constructUnarySpec notTerm pevalNotTerm + +andSpec :: (TermRewritingSpec a Bool) => a -> a -> a +andSpec = constructBinarySpec andTerm pevalAndTerm + +orSpec :: (TermRewritingSpec a Bool) => a -> a -> a +orSpec = constructBinarySpec orTerm pevalOrTerm + +eqvSpec :: (TermRewritingSpec a av, TermRewritingSpec b Bool) => a -> a -> b +eqvSpec = constructBinarySpec eqvTerm pevalEqvTerm + +iteSpec :: (TermRewritingSpec a Bool, TermRewritingSpec b bv) => a -> b -> b -> b +iteSpec = constructTernarySpec iteTerm pevalITETerm + +addNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -> a +addNumSpec = constructBinarySpec addNumTerm pevalAddNumTerm + +uminusNumSpec :: (TermRewritingSpec a av, Num av) => a -> a +uminusNumSpec = constructUnarySpec uminusNumTerm pevalUMinusNumTerm + +timesNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -> a +timesNumSpec = constructBinarySpec timesNumTerm pevalTimesNumTerm + +absNumSpec :: (TermRewritingSpec a av, Num av) => a -> a +absNumSpec = constructUnarySpec absNumTerm pevalAbsNumTerm + +signumNumSpec :: (TermRewritingSpec a av, Num av) => a -> a +signumNumSpec = constructUnarySpec signumNumTerm pevalSignumNumTerm + +ltNumSpec :: (TermRewritingSpec a av, Num av, Ord av, TermRewritingSpec b Bool) => a -> a -> b +ltNumSpec = constructBinarySpec ltNumTerm pevalLtNumTerm + +leNumSpec :: (TermRewritingSpec a av, Num av, Ord av, TermRewritingSpec b Bool) => a -> a -> b +leNumSpec = constructBinarySpec leNumTerm pevalLeNumTerm + +andBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a +andBitsSpec = constructBinarySpec andBitsTerm pevalAndBitsTerm + +orBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a +orBitsSpec = constructBinarySpec orBitsTerm pevalOrBitsTerm + +xorBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a +xorBitsSpec = constructBinarySpec xorBitsTerm pevalXorBitsTerm + +complementBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a +complementBitsSpec = constructUnarySpec complementBitsTerm pevalComplementBitsTerm + +shiftBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> Int -> a +shiftBitsSpec a n = constructUnarySpec (`shiftBitsTerm` n) (`pevalShiftBitsTerm` n) a + +rotateBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> Int -> a +rotateBitsSpec a n = constructUnarySpec (`rotateBitsTerm` n) (`pevalRotateBitsTerm` n) a + +bvconcatSpec :: + ( TermRewritingSpec a (bv an), + TermRewritingSpec b (bv bn), + TermRewritingSpec c (bv cn), + KnownNat an, + KnownNat bn, + KnownNat cn, + BVConcat (bv an) (bv bn) (bv cn) + ) => + a -> + b -> + c +bvconcatSpec = constructBinarySpec bvconcatTerm pevalBVConcatTerm + +bvselectSpec :: + ( TermRewritingSpec a (bv an), + TermRewritingSpec b (bv bn), + KnownNat an, + KnownNat bn, + KnownNat ix, + BVSelect (bv an) ix bn (bv bn) + ) => + proxy ix -> + proxy bn -> + a -> + b +bvselectSpec p1 p2 = constructUnarySpec (bvselectTerm p1 p2) (pevalBVSelectTerm p1 p2) + +bvextendSpec :: + ( TermRewritingSpec a (bv an), + TermRewritingSpec b (bv bn), + KnownNat an, + KnownNat bn, + BVExtend (bv an) bn (bv bn) + ) => + Bool -> + proxy bn -> + a -> + b +bvextendSpec signed p = constructUnarySpec (bvextendTerm signed p) (pevalBVExtendTerm signed p) + +divIntegerSpec :: (TermRewritingSpec a Integer) => a -> a -> a +divIntegerSpec = constructBinarySpec divIntegerTerm pevalDivIntegerTerm + +modIntegerSpec :: (TermRewritingSpec a Integer) => a -> a -> a +modIntegerSpec = constructBinarySpec modIntegerTerm pevalModIntegerTerm + +data BoolOnlySpec = BoolOnlySpec (Term Bool) (Term Bool) + +instance Show BoolOnlySpec where + show (BoolOnlySpec n r) = "BoolOnlySpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec BoolOnlySpec Bool where + norewriteVer (BoolOnlySpec n _) = n + rewriteVer (BoolOnlySpec _ r) = r + wrap = BoolOnlySpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) + +boolonly :: Int -> Gen BoolOnlySpec +boolonly 0 = + let s = + oneof $ + return . symSpec . (++ "bool") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = oneof $ return . conSpec <$> [True, False] + in oneof [r, s] +boolonly n | n > 0 = do + v1 <- boolonly (n - 1) + v2 <- boolonly (n - 1) + v3 <- boolonly (n - 1) + oneof + [ return $ notSpec v1, + return $ andSpec v1 v2, + return $ orSpec v1 v2, + return $ eqvSpec v1 v2, + return $ iteSpec v1 v2 v3 + ] +boolonly _ = error "Should never be called" + +instance Arbitrary BoolOnlySpec where + arbitrary = sized boolonly + +data BoolWithLIASpec = BoolWithLIASpec (Term Bool) (Term Bool) + +instance Show BoolWithLIASpec where + show (BoolWithLIASpec n r) = "BoolWithLIASpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec BoolWithLIASpec Bool where + norewriteVer (BoolWithLIASpec n _) = n + rewriteVer (BoolWithLIASpec _ r) = r + wrap = BoolWithLIASpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) + +data LIAWithBoolSpec = LIAWithBoolSpec (Term Integer) (Term Integer) + +instance Show LIAWithBoolSpec where + show (LIAWithBoolSpec n r) = + "LIAWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec LIAWithBoolSpec Integer where + norewriteVer (LIAWithBoolSpec n _) = n + rewriteVer (LIAWithBoolSpec _ r) = r + wrap = LIAWithBoolSpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) + +boolWithLIA :: Int -> Gen BoolWithLIASpec +boolWithLIA 0 = + let s = + oneof $ + return . symSpec . (++ "bool") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = oneof $ return . conSpec <$> [True, False] + in oneof [r, s] +boolWithLIA n | n > 0 = do + v1 <- boolWithLIA (n - 1) + v2 <- boolWithLIA (n - 1) + v3 <- boolWithLIA (n - 1) + v1i <- liaWithBool (n - 1) + v2i <- liaWithBool (n - 1) + frequency + [ (1, return $ notSpec v1), + (1, return $ andSpec v1 v2), + (1, return $ orSpec v1 v2), + (1, return $ eqvSpec v1 v2), + (5, return $ eqvSpec v1i v2i), + (5, return $ ltNumSpec v1i v2i), + (5, return $ leNumSpec v1i v2i), + (1, return $ iteSpec v1 v2 v3) + ] +boolWithLIA _ = error "Should never be called" + +liaWithBool :: Int -> Gen LIAWithBoolSpec +liaWithBool 0 = + let s = + oneof $ + return . symSpec . (++ "int") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec <$> arbitrary + in oneof [r, s] +liaWithBool n | n > 0 = do + v1b <- boolWithLIA (n - 1) + v1i <- liaWithBool (n - 1) + v2i <- liaWithBool (n - 1) + oneof + [ return $ uminusNumSpec v1i, + return $ absNumSpec v1i, + return $ signumNumSpec v1i, + return $ addNumSpec v1i v2i, + return $ iteSpec v1b v1i v2i + ] +liaWithBool _ = error "Should never be called" + +instance Arbitrary BoolWithLIASpec where + arbitrary = sized boolWithLIA + +instance Arbitrary LIAWithBoolSpec where + arbitrary = sized liaWithBool + +data FixedSizedBVWithBoolSpec bv = FixedSizedBVWithBoolSpec (Term (bv 4)) (Term (bv 4)) + +instance (SupportedPrim (bv 4)) => Show (FixedSizedBVWithBoolSpec bv) where + show (FixedSizedBVWithBoolSpec n r) = "FixedSizedBVWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance (SupportedPrim (bv 4)) => TermRewritingSpec (FixedSizedBVWithBoolSpec bv) (bv 4) where + norewriteVer (FixedSizedBVWithBoolSpec n _) = n + rewriteVer (FixedSizedBVWithBoolSpec _ r) = r + wrap = FixedSizedBVWithBoolSpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) + +data BoolWithFixedSizedBVSpec (bv :: Nat -> Type) = BoolWithFixedSizedBVSpec (Term Bool) (Term Bool) + +instance Show (BoolWithFixedSizedBVSpec bv) where + show (BoolWithFixedSizedBVSpec n r) = + "BoolWithFixedSizedBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec (BoolWithFixedSizedBVSpec bv) Bool where + norewriteVer (BoolWithFixedSizedBVSpec n _) = n + rewriteVer (BoolWithFixedSizedBVSpec _ r) = r + wrap = BoolWithFixedSizedBVSpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) + +boolWithFSBV :: forall proxy bv. (SupportedPrim (bv 4), Ord (bv 4), Num (bv 4), Bits (bv 4)) => proxy bv -> Int -> Gen (BoolWithFixedSizedBVSpec bv) +boolWithFSBV _ 0 = + let s = + oneof $ + return . symSpec . (++ "bool") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = oneof $ return . conSpec <$> [True, False] + in oneof [r, s] +boolWithFSBV p n | n > 0 = do + v1 <- boolWithFSBV p (n - 1) + v2 <- boolWithFSBV p (n - 1) + v3 <- boolWithFSBV p (n - 1) + v1i <- fsbvWithBool p (n - 1) + v2i <- fsbvWithBool p (n - 1) + frequency + [ (1, return $ notSpec v1), + (1, return $ andSpec v1 v2), + (1, return $ orSpec v1 v2), + (1, return $ eqvSpec v1 v2), + (5, return $ eqvSpec v1i v2i), + (5, return $ ltNumSpec v1i v2i), + (5, return $ leNumSpec v1i v2i), + (1, return $ iteSpec v1 v2 v3) + ] +boolWithFSBV _ _ = error "Should never be called" + +fsbvWithBool :: + forall proxy bv. + (SupportedPrim (bv 4), Ord (bv 4), Num (bv 4), Bits (bv 4)) => + proxy bv -> + Int -> + Gen (FixedSizedBVWithBoolSpec bv) +fsbvWithBool _ 0 = + let s = + oneof $ + return . symSpec . (++ "int") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +fsbvWithBool p n | n > 0 = do + v1b <- boolWithFSBV p (n - 1) + v1i <- fsbvWithBool p (n - 1) + v2i <- fsbvWithBool p (n - 1) + i <- arbitrary + oneof + [ return $ uminusNumSpec v1i, + return $ absNumSpec v1i, + return $ signumNumSpec v1i, + return $ addNumSpec v1i v2i, + return $ timesNumSpec v1i v2i, + return $ andBitsSpec v1i v2i, + return $ orBitsSpec v1i v2i, + return $ xorBitsSpec v1i v2i, + return $ complementBitsSpec v1i, + return $ shiftBitsSpec v1i i, + return $ rotateBitsSpec v1i i, + return $ iteSpec v1b v1i v2i + ] +fsbvWithBool _ _ = error "Should never be called" + +instance (SupportedPrim (bv 4), Ord (bv 4), Num (bv 4), Bits (bv 4)) => Arbitrary (BoolWithFixedSizedBVSpec bv) where + arbitrary = sized (boolWithFSBV (Proxy @bv)) + +instance (SupportedPrim (bv 4), Ord (bv 4), Num (bv 4), Bits (bv 4)) => Arbitrary (FixedSizedBVWithBoolSpec bv) where + arbitrary = sized (fsbvWithBool Proxy) + +data DifferentSizeBVSpec bv (n :: Nat) = DifferentSizeBVSpec (Term (bv n)) (Term (bv n)) + +instance (SupportedPrim (bv n)) => Show (DifferentSizeBVSpec bv n) where + show (DifferentSizeBVSpec n r) = "DSizeBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance (SupportedPrim (bv n)) => TermRewritingSpec (DifferentSizeBVSpec bv n) (bv n) where + norewriteVer (DifferentSizeBVSpec n _) = n + rewriteVer (DifferentSizeBVSpec _ r) = r + wrap = DifferentSizeBVSpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) + +type SupportedBV bv (n :: Nat) = + (SupportedPrim (bv n), Ord (bv n), Num (bv n), Bits (bv n)) + +dsbv1 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + BVSelect (bv 4) 0 2 (bv 2), + BVSelect (bv 4) 1 2 (bv 2), + BVSelect (bv 4) 2 2 (bv 2), + BVSelect (bv 3) 0 2 (bv 2), + BVSelect (bv 3) 1 2 (bv 2), + BVSelect (bv 2) 0 2 (bv 2), + BVConcat (bv 1) (bv 1) (bv 2), + BVExtend (bv 1) 2 (bv 2), + BVSelect (bv 4) 0 1 (bv 1), + BVSelect (bv 4) 1 1 (bv 1), + BVSelect (bv 4) 2 1 (bv 1), + BVSelect (bv 4) 3 1 (bv 1), + BVSelect (bv 3) 0 1 (bv 1), + BVSelect (bv 3) 1 1 (bv 1), + BVSelect (bv 3) 2 1 (bv 1), + BVSelect (bv 2) 0 1 (bv 1), + BVSelect (bv 2) 1 1 (bv 1), + BVSelect (bv 1) 0 1 (bv 1), + BVSelect (bv 4) 0 3 (bv 3), + BVSelect (bv 4) 1 3 (bv 3), + BVSelect (bv 3) 0 3 (bv 3), + BVConcat (bv 1) (bv 2) (bv 3), + BVConcat (bv 2) (bv 1) (bv 3), + BVExtend (bv 1) 3 (bv 3), + BVExtend (bv 2) 3 (bv 3), + BVSelect (bv 4) 0 4 (bv 4), + BVConcat (bv 1) (bv 3) (bv 4), + BVConcat (bv 2) (bv 2) (bv 4), + BVConcat (bv 3) (bv 1) (bv 4), + BVExtend (bv 1) 4 (bv 4), + BVExtend (bv 2) 4 (bv 4), + BVExtend (bv 3) 4 (bv 4) + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 1) +dsbv1 _ 0 = + let s = + oneof $ + return . symSpec . (++ "bv1") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv1 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v1' <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + i <- arbitrary + oneof + [ return $ uminusNumSpec v1, + return $ absNumSpec v1, + return $ signumNumSpec v1, + return $ addNumSpec v1 v1', + return $ timesNumSpec v1 v1', + return $ andBitsSpec v1 v1', + return $ orBitsSpec v1 v1', + return $ xorBitsSpec v1 v1', + return $ complementBitsSpec v1, + return $ shiftBitsSpec v1 i, + return $ rotateBitsSpec v1 i, + return $ bvselectSpec (Proxy @0) (Proxy @1) v4, + return $ bvselectSpec (Proxy @1) (Proxy @1) v4, + return $ bvselectSpec (Proxy @2) (Proxy @1) v4, + return $ bvselectSpec (Proxy @3) (Proxy @1) v4, + return $ bvselectSpec (Proxy @0) (Proxy @1) v3, + return $ bvselectSpec (Proxy @1) (Proxy @1) v3, + return $ bvselectSpec (Proxy @2) (Proxy @1) v3, + return $ bvselectSpec (Proxy @0) (Proxy @1) v2, + return $ bvselectSpec (Proxy @1) (Proxy @1) v2, + return $ bvselectSpec (Proxy @0) (Proxy @1) v1 + ] +dsbv1 _ _ = error "Should never be called" + +dsbv2 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + BVSelect (bv 4) 0 2 (bv 2), + BVSelect (bv 4) 1 2 (bv 2), + BVSelect (bv 4) 2 2 (bv 2), + BVSelect (bv 3) 0 2 (bv 2), + BVSelect (bv 3) 1 2 (bv 2), + BVSelect (bv 2) 0 2 (bv 2), + BVConcat (bv 1) (bv 1) (bv 2), + BVExtend (bv 1) 2 (bv 2), + BVSelect (bv 4) 0 1 (bv 1), + BVSelect (bv 4) 1 1 (bv 1), + BVSelect (bv 4) 2 1 (bv 1), + BVSelect (bv 4) 3 1 (bv 1), + BVSelect (bv 3) 0 1 (bv 1), + BVSelect (bv 3) 1 1 (bv 1), + BVSelect (bv 3) 2 1 (bv 1), + BVSelect (bv 2) 0 1 (bv 1), + BVSelect (bv 2) 1 1 (bv 1), + BVSelect (bv 1) 0 1 (bv 1), + BVSelect (bv 4) 0 3 (bv 3), + BVSelect (bv 4) 1 3 (bv 3), + BVSelect (bv 3) 0 3 (bv 3), + BVConcat (bv 1) (bv 2) (bv 3), + BVConcat (bv 2) (bv 1) (bv 3), + BVExtend (bv 1) 3 (bv 3), + BVExtend (bv 2) 3 (bv 3), + BVSelect (bv 4) 0 4 (bv 4), + BVConcat (bv 1) (bv 3) (bv 4), + BVConcat (bv 2) (bv 2) (bv 4), + BVConcat (bv 3) (bv 1) (bv 4), + BVExtend (bv 1) 4 (bv 4), + BVExtend (bv 2) 4 (bv 4), + BVExtend (bv 3) 4 (bv 4) + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 2) +dsbv2 _ 0 = + let s = + oneof $ + return . symSpec . (++ "bv2") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv2 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v1' <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v2' <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + i <- arbitrary + oneof + [ return $ uminusNumSpec v2, + return $ absNumSpec v2, + return $ signumNumSpec v2, + return $ addNumSpec v2 v2', + return $ timesNumSpec v2 v2', + return $ andBitsSpec v2 v2', + return $ orBitsSpec v2 v2', + return $ xorBitsSpec v2 v2', + return $ complementBitsSpec v2, + return $ shiftBitsSpec v2 i, + return $ rotateBitsSpec v2 i, + return $ bvselectSpec (Proxy @0) (Proxy @2) v4, + return $ bvselectSpec (Proxy @1) (Proxy @2) v4, + return $ bvselectSpec (Proxy @2) (Proxy @2) v4, + return $ bvselectSpec (Proxy @0) (Proxy @2) v3, + return $ bvselectSpec (Proxy @1) (Proxy @2) v3, + return $ bvselectSpec (Proxy @0) (Proxy @2) v2, + return $ bvconcatSpec v1 v1', + return $ bvextendSpec False (Proxy @2) v1, + return $ bvextendSpec True (Proxy @2) v1 + ] +dsbv2 _ _ = error "Should never be called" + +dsbv3 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + BVSelect (bv 4) 0 2 (bv 2), + BVSelect (bv 4) 1 2 (bv 2), + BVSelect (bv 4) 2 2 (bv 2), + BVSelect (bv 3) 0 2 (bv 2), + BVSelect (bv 3) 1 2 (bv 2), + BVSelect (bv 2) 0 2 (bv 2), + BVConcat (bv 1) (bv 1) (bv 2), + BVExtend (bv 1) 2 (bv 2), + BVSelect (bv 4) 0 1 (bv 1), + BVSelect (bv 4) 1 1 (bv 1), + BVSelect (bv 4) 2 1 (bv 1), + BVSelect (bv 4) 3 1 (bv 1), + BVSelect (bv 3) 0 1 (bv 1), + BVSelect (bv 3) 1 1 (bv 1), + BVSelect (bv 3) 2 1 (bv 1), + BVSelect (bv 2) 0 1 (bv 1), + BVSelect (bv 2) 1 1 (bv 1), + BVSelect (bv 1) 0 1 (bv 1), + BVSelect (bv 4) 0 3 (bv 3), + BVSelect (bv 4) 1 3 (bv 3), + BVSelect (bv 3) 0 3 (bv 3), + BVConcat (bv 1) (bv 2) (bv 3), + BVConcat (bv 2) (bv 1) (bv 3), + BVExtend (bv 1) 3 (bv 3), + BVExtend (bv 2) 3 (bv 3), + BVSelect (bv 4) 0 4 (bv 4), + BVConcat (bv 1) (bv 3) (bv 4), + BVConcat (bv 2) (bv 2) (bv 4), + BVConcat (bv 3) (bv 1) (bv 4), + BVExtend (bv 1) 4 (bv 4), + BVExtend (bv 2) 4 (bv 4), + BVExtend (bv 3) 4 (bv 4) + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 3) +dsbv3 _ 0 = + let s = + oneof $ + return . symSpec . (++ "bv3") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv3 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v3' <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + i <- arbitrary + oneof + [ return $ uminusNumSpec v3, + return $ absNumSpec v3, + return $ signumNumSpec v3, + return $ addNumSpec v3 v3', + return $ timesNumSpec v3 v3', + return $ andBitsSpec v3 v3', + return $ orBitsSpec v3 v3', + return $ xorBitsSpec v3 v3', + return $ complementBitsSpec v3, + return $ shiftBitsSpec v3 i, + return $ rotateBitsSpec v3 i, + return $ bvselectSpec (Proxy @0) (Proxy @3) v4, + return $ bvselectSpec (Proxy @1) (Proxy @3) v4, + return $ bvselectSpec (Proxy @0) (Proxy @3) v3, + return $ bvconcatSpec v1 v2, + return $ bvconcatSpec v2 v1, + return $ bvextendSpec False (Proxy @3) v1, + return $ bvextendSpec True (Proxy @3) v1, + return $ bvextendSpec False (Proxy @3) v2, + return $ bvextendSpec True (Proxy @3) v2 + ] +dsbv3 _ _ = error "Should never be called" + +dsbv4 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + BVSelect (bv 4) 0 2 (bv 2), + BVSelect (bv 4) 1 2 (bv 2), + BVSelect (bv 4) 2 2 (bv 2), + BVSelect (bv 3) 0 2 (bv 2), + BVSelect (bv 3) 1 2 (bv 2), + BVSelect (bv 2) 0 2 (bv 2), + BVConcat (bv 1) (bv 1) (bv 2), + BVExtend (bv 1) 2 (bv 2), + BVSelect (bv 4) 0 1 (bv 1), + BVSelect (bv 4) 1 1 (bv 1), + BVSelect (bv 4) 2 1 (bv 1), + BVSelect (bv 4) 3 1 (bv 1), + BVSelect (bv 3) 0 1 (bv 1), + BVSelect (bv 3) 1 1 (bv 1), + BVSelect (bv 3) 2 1 (bv 1), + BVSelect (bv 2) 0 1 (bv 1), + BVSelect (bv 2) 1 1 (bv 1), + BVSelect (bv 1) 0 1 (bv 1), + BVSelect (bv 4) 0 3 (bv 3), + BVSelect (bv 4) 1 3 (bv 3), + BVSelect (bv 3) 0 3 (bv 3), + BVConcat (bv 1) (bv 2) (bv 3), + BVConcat (bv 2) (bv 1) (bv 3), + BVExtend (bv 1) 3 (bv 3), + BVExtend (bv 2) 3 (bv 3), + BVSelect (bv 4) 0 4 (bv 4), + BVConcat (bv 1) (bv 3) (bv 4), + BVConcat (bv 2) (bv 2) (bv 4), + BVConcat (bv 3) (bv 1) (bv 4), + BVExtend (bv 1) 4 (bv 4), + BVExtend (bv 2) 4 (bv 4), + BVExtend (bv 3) 4 (bv 4) + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 4) +dsbv4 _ 0 = + let s = + oneof $ + return . symSpec . (++ "bv4") + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv4 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v2' <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + v4' <- dsbv4 p (depth - 1) + i <- arbitrary + oneof + [ return $ uminusNumSpec v4, + return $ absNumSpec v4, + return $ signumNumSpec v4, + return $ addNumSpec v4 v4', + return $ timesNumSpec v4 v4', + return $ andBitsSpec v4 v4', + return $ orBitsSpec v4 v4', + return $ xorBitsSpec v4 v4', + return $ complementBitsSpec v4, + return $ shiftBitsSpec v4 i, + return $ rotateBitsSpec v4 i, + return $ bvselectSpec (Proxy @0) (Proxy @4) v4, + return $ bvconcatSpec v1 v3, + return $ bvconcatSpec v2 v2', + return $ bvconcatSpec v3 v1, + return $ bvextendSpec False (Proxy @4) v1, + return $ bvextendSpec True (Proxy @4) v1, + return $ bvextendSpec False (Proxy @4) v2, + return $ bvextendSpec True (Proxy @4) v2, + return $ bvextendSpec False (Proxy @4) v3, + return $ bvextendSpec True (Proxy @4) v3 + ] +dsbv4 _ _ = error "Should never be called" + +instance + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + BVSelect (bv 4) 0 2 (bv 2), + BVSelect (bv 4) 1 2 (bv 2), + BVSelect (bv 4) 2 2 (bv 2), + BVSelect (bv 3) 0 2 (bv 2), + BVSelect (bv 3) 1 2 (bv 2), + BVSelect (bv 2) 0 2 (bv 2), + BVConcat (bv 1) (bv 1) (bv 2), + BVExtend (bv 1) 2 (bv 2), + BVSelect (bv 4) 0 1 (bv 1), + BVSelect (bv 4) 1 1 (bv 1), + BVSelect (bv 4) 2 1 (bv 1), + BVSelect (bv 4) 3 1 (bv 1), + BVSelect (bv 3) 0 1 (bv 1), + BVSelect (bv 3) 1 1 (bv 1), + BVSelect (bv 3) 2 1 (bv 1), + BVSelect (bv 2) 0 1 (bv 1), + BVSelect (bv 2) 1 1 (bv 1), + BVSelect (bv 1) 0 1 (bv 1), + BVSelect (bv 4) 0 3 (bv 3), + BVSelect (bv 4) 1 3 (bv 3), + BVSelect (bv 3) 0 3 (bv 3), + BVConcat (bv 1) (bv 2) (bv 3), + BVConcat (bv 2) (bv 1) (bv 3), + BVExtend (bv 1) 3 (bv 3), + BVExtend (bv 2) 3 (bv 3), + BVSelect (bv 4) 0 4 (bv 4), + BVConcat (bv 1) (bv 3) (bv 4), + BVConcat (bv 2) (bv 2) (bv 4), + BVConcat (bv 3) (bv 1) (bv 4), + BVExtend (bv 1) 4 (bv 4), + BVExtend (bv 2) 4 (bv 4), + BVExtend (bv 3) 4 (bv 4) + ) => + Arbitrary (DifferentSizeBVSpec bv 4) + where + arbitrary = sized (dsbv4 Proxy) + +data GeneralSpec s = GeneralSpec (Term s) (Term s) + +instance (SupportedPrim s) => Show (GeneralSpec s) where + show (GeneralSpec n r) = "GeneralSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance (SupportedPrim s) => TermRewritingSpec (GeneralSpec s) s where + norewriteVer (GeneralSpec n _) = n + rewriteVer (GeneralSpec _ r) = r + wrap = GeneralSpec + same s = eqvTerm (norewriteVer s) (rewriteVer s) diff --git a/test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs b/test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Backend.SBV.Data.SMT.TermRewritingTests where + +import Data.Foldable +import qualified Data.SBV as SBV +import Grisette.Backend.SBV.Data.SMT.Solving +import Grisette.Backend.SBV.Data.SMT.TermRewritingGen +import Grisette.Core.Data.Class.Solver +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils +import Grisette.IR.SymPrim.Data.SymPrim +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +validateSpec :: (TermRewritingSpec a av, Show a, SupportedPrim av) => GrisetteSMTConfig n -> a -> Assertion +validateSpec config a = do + r <- solve config (Sym $ counterExample a) + rs <- solve config (Sym $ same a) + case (r, rs) of + (Left _, Right _) -> do + return () + (Left _, Left _) -> do + assertFailure $ "Bad rewriting with unsolvable formula: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a) + (Right m, _) -> do + assertFailure $ "With model" ++ show m ++ "Bad rewriting: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a) + +termRewritingTests :: TestTree +termRewritingTests = + let unboundedConfig = UnboundedReasoning SBV.z3 -- {SBV.verbose=True} + in testGroup + "TermRewritingTests" + [ testGroup + "Bool only" + [ testProperty "Bool only random test" $ + mapSize (`min` 10) $ + ioProperty . \(x :: BoolOnlySpec) -> do + validateSpec unboundedConfig x, + testCase "Regression nested ite with (ite a (ite b c d) e) with b is true" $ do + validateSpec @BoolOnlySpec + unboundedConfig + ( iteSpec + (symSpec "a" :: BoolOnlySpec) + ( iteSpec + (orSpec (notSpec (andSpec (symSpec "b1") (symSpec "b2"))) (symSpec "b2") :: BoolOnlySpec) + (symSpec "c") + (symSpec "d") + ) + (symSpec "e") + ), + testCase "Regression for pevalImpliesTerm _ false should be false" $ do + validateSpec @BoolOnlySpec + unboundedConfig + ( iteSpec + (symSpec "fbool" :: BoolOnlySpec) + ( notSpec + ( orSpec + (orSpec (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "fbool" :: BoolOnlySpec))) (symSpec "gbool" :: BoolOnlySpec)) + (orSpec (symSpec "abool" :: BoolOnlySpec) (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "bbool" :: BoolOnlySpec)))) + ) + ) + (symSpec "xxx" :: BoolOnlySpec) + ) + ], + testGroup + "LIA" + [ testProperty "LIA random test" $ + mapSize (`min` 10) $ + ioProperty . \(x :: LIAWithBoolSpec) -> do + validateSpec unboundedConfig x, + testCase "Regression nested ite with (ite a b (ite c d e)) with c implies a" $ do + validateSpec @LIAWithBoolSpec + unboundedConfig + ( iteSpec + (notSpec (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 1 :: LIAWithBoolSpec) :: BoolWithLIASpec)) + (symSpec "b") + ( iteSpec + (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 2 :: LIAWithBoolSpec) :: BoolWithLIASpec) + (symSpec "d") + (symSpec "d") + ) + ) + ], + testGroup + "Different sized SignedBV" + [ testProperty "Fixed Sized SignedBV random test" $ + mapSize (`min` 10) $ + ioProperty . \(x :: (DifferentSizeBVSpec IntN 4)) -> do + validateSpec unboundedConfig x + ], + testGroup + "Fixed sized SignedBV" + [ testProperty "Fixed Sized SignedBV random test" $ + mapSize (`min` 10) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN)) -> do + validateSpec unboundedConfig x + ], + testGroup + "timesNumSpec on integer" + [ testCase "times on both concrete" $ do + traverse_ + (\(x, y) -> validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (conSpec y)) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "times on single concrete" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "a") (conSpec x) + ) + [-3 .. 3], + testCase "Two times with two concrete combined" $ do + traverse_ + ( \(x, y) -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (conSpec y) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (symSpec "a") (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "Two times with one concrete" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (symSpec "b") (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "b") $ timesNumSpec (symSpec "a") (conSpec x) + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "b") $ timesNumSpec (conSpec x) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (symSpec "b") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (symSpec "b") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (symSpec "b")) (conSpec x) + ) + [-3 .. 3], + testCase "times and add with two concretes combined" $ do + traverse_ + ( \(x, y) -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ addNumSpec (conSpec y) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ addNumSpec (symSpec "a") (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (addNumSpec (conSpec x) (symSpec "a")) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (addNumSpec (symSpec "a") (conSpec x)) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ timesNumSpec (conSpec y) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ timesNumSpec (symSpec "a") (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "times concrete with uminusNumSpec symbolic" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (uminusNumSpec $ symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (uminusNumSpec $ symSpec "a") (conSpec x) + ) + [-3 .. 3] + ], + testGroup + "DivI" + [ testCase "DivI on concrete" $ do + traverse_ + ( \(x, y) -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ divIntegerSpec (conSpec x) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "DivI on single concrete" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ divIntegerSpec (conSpec x) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ divIntegerSpec (symSpec "a") (conSpec x) + ) + [-3 .. 3] + ], + testGroup + "ModI" + [ testCase "ModI on concrete" $ do + traverse_ + ( \(x, y) -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ modIntegerSpec (conSpec x) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "ModI on single concrete" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ modIntegerSpec (conSpec x) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ modIntegerSpec (symSpec "a") (conSpec x) + ) + [-3 .. 3] + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/BVTests.hs b/test/Grisette/IR/SymPrim/Data/BVTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/BVTests.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.IR.SymPrim.Data.BVTests where + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Bifunctor +import Data.Bits +import Data.Int +import Data.Proxy +import Data.Typeable +import Data.Word +import Grisette.Core.Data.Class.BitVector +import Grisette.IR.SymPrim.Data.BV +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck hiding ((.&.)) + +unaryConform :: forall a b c d. (Show c, Eq c, HasCallStack) => (a -> b) -> (d -> c) -> (a -> c) -> (b -> d) -> a -> Property +unaryConform a2b d2c f g x = ioProperty $ f x @=? d2c (g (a2b x)) + +binaryConform :: + forall a b c d e f. + (Show e, Eq e, HasCallStack) => + (a -> b) -> + (c -> d) -> + (f -> e) -> + (a -> c -> e) -> + (b -> d -> f) -> + a -> + c -> + Property +binaryConform a2b c2d f2e f g x y = ioProperty $ f x y @=? f2e (g (a2b x) (c2d y)) + +wordUnaryConform :: HasCallStack => (WordN 8 -> WordN 8) -> (Word8 -> Word8) -> Word8 -> Assertion +wordUnaryConform f g x = unWordN (f (fromIntegral x)) @=? toInteger (g x) + +wordUnaryNonNegIntConform :: HasCallStack => (Int -> WordN 8) -> (Int -> Word8) -> Int -> Assertion +wordUnaryNonNegIntConform f g y = when (y >= 0) $ unWordN (f y) @=? toInteger (g y) + +wordBinIntConform :: HasCallStack => (WordN 8 -> Int -> WordN 8) -> (Word8 -> Int -> Word8) -> Word8 -> Int -> Assertion +wordBinIntConform f g x y = unWordN (f (fromIntegral x) y) @=? toInteger (g x y) + +wordBinNonNegIntConform :: HasCallStack => (WordN 8 -> Int -> WordN 8) -> (Word8 -> Int -> Word8) -> Word8 -> Int -> Assertion +wordBinNonNegIntConform f g x y = when (y >= 0) $ unWordN (f (fromIntegral x) y) @=? toInteger (g x y) + +wordBinConform :: HasCallStack => (WordN 8 -> WordN 8 -> WordN 8) -> (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> Assertion +wordBinConform f g x y = unWordN (f (fromIntegral x) (fromIntegral y)) @=? toInteger (g x y) + +intN8eqint8 :: IntN 8 -> Int8 -> Assertion +intN8eqint8 (IntN v) i + | v < 0 = assertFailure "Bad IntN" + | v <= 127 = v @=? fromIntegral i + | v == 128 = i @=? -128 + | otherwise = 256 - v @=? fromIntegral (-i) + +intUnaryConform :: (IntN 8 -> IntN 8) -> (Int8 -> Int8) -> Int8 -> Assertion +intUnaryConform f g x = intN8eqint8 (f (fromIntegral x)) (g x) + +intUnaryNonNegIntConform :: (Int -> IntN 8) -> (Int -> Int8) -> Int -> Assertion +intUnaryNonNegIntConform f g y = when (y >= 0) $ intN8eqint8 (f y) (g y) + +intBinIntConform :: (IntN 8 -> Int -> IntN 8) -> (Int8 -> Int -> Int8) -> Int8 -> Int -> Assertion +intBinIntConform f g x y = intN8eqint8 (f (fromIntegral x) y) (g x y) + +intBinNonNegIntConform :: (IntN 8 -> Int -> IntN 8) -> (Int8 -> Int -> Int8) -> Int8 -> Int -> Assertion +intBinNonNegIntConform f g x y = when (y >= 0) $ intN8eqint8 (f (fromIntegral x) y) (g x y) + +intBinConform :: (IntN 8 -> IntN 8 -> IntN 8) -> (Int8 -> Int8 -> Int8) -> Int8 -> Int8 -> Assertion +intBinConform f g x y = intN8eqint8 (f (fromIntegral x) (fromIntegral y)) (g x y) + +finiteBitsConformTest :: + forall ref typ. + (Arbitrary ref, Typeable ref, Typeable typ, Show ref, Show typ, Eq ref, Eq typ, FiniteBits ref, FiniteBits typ, Integral ref, Integral typ) => + Proxy ref -> + Proxy typ -> + Int -> + TestTree +finiteBitsConformTest pref ptyp numBits = + testGroup + (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for FiniteBits instances") + [ testCase "finiteBitSize" $ finiteBitSize (0 :: typ) @=? numBits, + testProperty "countLeadingZeros" $ unaryConform @ref @typ fromIntegral id countLeadingZeros countLeadingZeros, + testProperty "countTrailingZeros" $ unaryConform @ref @typ fromIntegral id countTrailingZeros countTrailingZeros + ] + +boundedConformTest :: + forall ref typ. + (Typeable ref, Typeable typ, Bounded typ, Bounded ref, Integral ref, Num typ, Eq typ, Show typ) => + Proxy ref -> + Proxy typ -> + TestTree +boundedConformTest pref ptyp = + testGroup + (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Bounded instances") + [ testCase "minBound" $ (minBound :: typ) @=? fromIntegral (minBound :: ref), + testCase "maxBound" $ (maxBound :: typ) @=? fromIntegral (maxBound :: ref) + ] + +shouldThrow :: NFData a => String -> a -> IO () +shouldThrow name x = do + errored <- catch (evaluate $ x `deepseq` True) (\(_ :: SomeException) -> return False) + when errored $ assertFailure $ name ++ " should throw an exception" + +succPredLikeTest :: + forall a b. + (Arbitrary a, Eq a, Eq b, Show a, Show b, NFData b) => + TestName -> + String -> + (a -> b) -> + (a -> a) -> + (b -> b) -> + a -> + b -> + TestTree +succPredLikeTest name boundName a2b fa fb bounda boundb = + testGroup + name + [ testProperty (name ++ " non " ++ boundName) $ + ioProperty . \(x :: a) -> + if x == bounda then return () else a2b (fa x) @=? fb (a2b x), + testCase (name ++ " " ++ boundName) $ shouldThrow (name ++ " " ++ boundName) $ fb boundb + ] + +enumConformTest :: + forall ref typ. + ( Arbitrary ref, + Typeable ref, + Typeable typ, + Eq ref, + Eq typ, + Show ref, + Show typ, + NFData typ, + Integral ref, + Integral typ, + Bounded ref, + Bounded typ + ) => + Proxy ref -> + Proxy typ -> + TestTree +enumConformTest pref ptyp = + testGroup + (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Enum instances") + [ succPredLikeTest @ref @typ "succ" "maxBound" fromIntegral succ succ maxBound maxBound, + succPredLikeTest @ref @typ "pred" "minBound" fromIntegral pred pred minBound minBound, + testGroup + "toEnum" + [ testProperty "toEnum in bounds" $ + ioProperty . \(x :: ref) -> + toInteger (toEnum (fromIntegral x) :: ref) @=? toInteger (toEnum (fromIntegral x) :: typ), + testCase "toEnum (fromIntegral minBound - 1)" $ + shouldThrow "toEnum (fromIntegral minBound - 1)" (toEnum (fromIntegral (minBound :: typ) - 1) :: typ), + testCase "toEnum (fromIntegral maxBound + 1)" $ + shouldThrow "toEnum (fromIntegral maxBound + 1)" (toEnum (fromIntegral (maxBound :: typ) + 1) :: typ) + ], + testProperty "fromEnum" $ unaryConform @ref @typ fromIntegral id fromEnum fromEnum, + testProperty "enumFrom" $ unaryConform @ref @typ fromIntegral (fromIntegral <$>) enumFrom enumFrom, + testProperty "enumFromThen" $ \(x :: ref) y -> + ioProperty $ do + if x == y + then return () + else do + (fromIntegral <$> enumFromThen x y) @=? enumFromThen (fromIntegral x :: typ) (fromIntegral y), + testProperty "enumFromTo" $ binaryConform @ref @typ fromIntegral fromIntegral (fromIntegral <$>) enumFromTo enumFromTo, + testProperty "enumFromThenTo" $ \(x :: ref) y z -> + ioProperty $ + if x == y + then return () + else (fromIntegral <$> enumFromThenTo x y z) @=? enumFromThenTo (fromIntegral x :: typ) (fromIntegral y) (fromIntegral z) + ] + +divLikeTest :: + forall a b. + (Arbitrary a, Eq a, Eq b, Num a, Show a, Bounded a, Bits a, Eq b, Show b, Num b, NFData b, Bounded b, Bits b) => + TestName -> + (a -> b) -> + (a -> a -> a) -> + (b -> b -> b) -> + TestTree +divLikeTest name a2b fa fb = + if isSigned (0 :: a) + then + testGroup + name + [ testProperty (name ++ " non zero / minBound vs -1") $ \(x :: a) y -> ioProperty $ do + if y == 0 || (x == minBound && y == -1) then return () else a2b (fa x y) @=? fb (a2b x) (a2b y), + testCase (name ++ " zero") $ shouldThrow (name ++ " zero") $ fb 1 0, + testCase (name ++ " minBound vs -1") $ shouldThrow (name ++ " minBound vs -1") $ fb minBound (-1) + ] + else + testGroup + name + [ testProperty (name ++ " non zero") $ \(x :: a) y -> ioProperty $ do + if y == 0 then return () else a2b (fa x y) @=? fb (a2b x) (a2b y), + testCase (name ++ " zero") $ shouldThrow (name ++ " zero") $ fb 1 0 + ] + +divModLikeTest :: + forall a b. + (Arbitrary a, Eq a, Eq b, Num a, Show a, Bounded a, Bits a, Eq b, Show b, Num b, NFData b, Bounded b, Bits b) => + TestName -> + (a -> b) -> + (a -> a -> (a, a)) -> + (b -> b -> (b, b)) -> + TestTree +divModLikeTest name a2b fa fb = + if isSigned (0 :: a) + then + testGroup + name + [ testProperty (name ++ " non zero / minBound vs -1") $ \(x :: a) y -> ioProperty $ do + if y == 0 || (x == minBound && y == -1) then return () else bimap a2b a2b (fa x y) @=? fb (a2b x) (a2b y), + testCase (name ++ " zero") $ shouldThrow (name ++ " zero") $ fb 1 0, + testCase (name ++ " minBound vs -1") $ shouldThrow (name ++ " minBound vs -1") $ fb minBound (-1) + ] + else + testGroup + name + [ testProperty (name ++ " non zero") $ \(x :: a) y -> ioProperty $ do + if y == 0 then return () else bimap a2b a2b (fa x y) @=? fb (a2b x) (a2b y), + testCase (name ++ " zero") $ shouldThrow (name ++ " zero") $ fb 1 0 + ] + +realConformTest :: + forall proxy ref typ. + (Typeable ref, Typeable typ, Integral ref, Num typ, Arbitrary ref, Real typ, Show ref) => + proxy ref -> + proxy typ -> + TestTree +realConformTest pref ptyp = + testGroup + (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Real instances") + [ testProperty "toRational" $ unaryConform @ref @typ fromIntegral id toRational toRational + ] + +integralConformTest :: + forall ref typ. + ( Arbitrary ref, + Typeable ref, + Typeable typ, + Eq ref, + Eq typ, + Show ref, + Show typ, + Num ref, + Num typ, + Integral ref, + Integral typ, + Bits ref, + Bits typ, + Bounded ref, + Bounded typ, + NFData typ + ) => + Proxy ref -> + Proxy typ -> + TestTree +integralConformTest pref ptyp = + testGroup + (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Integral instances") + [ divLikeTest @ref @typ "quot" fromIntegral quot quot, + divLikeTest @ref @typ "rem" fromIntegral rem rem, + divModLikeTest @ref @typ "quotRem" fromIntegral quotRem quotRem, + divLikeTest @ref @typ "div" fromIntegral div div, + divLikeTest @ref @typ "mod" fromIntegral mod mod, + divModLikeTest @ref @typ "divMod" fromIntegral divMod divMod, + testProperty "toInteger" $ unaryConform @ref @typ fromIntegral id toInteger toInteger + ] + +bvTests :: TestTree +bvTests = + testGroup + "BVTests" + [ testGroup + "WordN 8 conform to Word8 for Bits instances" + [ testProperty "(.&.)" $ \x y -> ioProperty $ wordBinConform (.&.) (.&.) x y, + testProperty "(.|.)" $ \x y -> ioProperty $ wordBinConform (.|.) (.|.) x y, + testProperty "xor" $ \x y -> ioProperty $ wordBinConform xor xor x y, + testProperty "complement" $ ioProperty . wordUnaryConform complement complement, + testProperty "shift" $ \x y -> ioProperty $ wordBinIntConform shift shift x y, + testProperty "rotate" $ \x y -> ioProperty $ wordBinIntConform rotate rotate x y, + testCase "zeroBits" $ (zeroBits :: WordN 8) @=? 0, + testProperty "bit" $ ioProperty . wordUnaryNonNegIntConform bit bit, + testProperty "setBit" $ \x y -> ioProperty $ wordBinNonNegIntConform setBit setBit x y, + testProperty "clearBit" $ \x y -> ioProperty $ wordBinNonNegIntConform clearBit clearBit x y, + testProperty "complementBit" $ \x y -> ioProperty $ wordBinNonNegIntConform complementBit complementBit x y, + testProperty "testBit" $ \(x :: Word8) i -> i < 0 || testBit x i == testBit (fromIntegral x :: WordN 8) i, + testCase "bitSizeMaybe" $ bitSizeMaybe (0 :: WordN 8) @=? Just 8, + testCase "isSigned" $ isSigned (0 :: WordN 8) @=? False, + testProperty "shiftL" $ \x y -> ioProperty $ wordBinNonNegIntConform shiftL shiftL x y, + testProperty "shiftR" $ \x y -> ioProperty $ wordBinNonNegIntConform shiftR shiftR x y, + testProperty "rotateL" $ \x y -> ioProperty $ wordBinNonNegIntConform rotateL rotateL x y, + testProperty "rotateR" $ \x y -> ioProperty $ wordBinNonNegIntConform rotateR rotateR x y, + testProperty "popCount" $ ioProperty . \(x :: Word8) -> popCount x @=? popCount (fromIntegral x :: WordN 8) + ], + finiteBitsConformTest (Proxy @Word8) (Proxy @(WordN 8)) 8, + boundedConformTest (Proxy @Word8) (Proxy @(WordN 8)), + enumConformTest (Proxy @Word8) (Proxy @(WordN 8)), + realConformTest (Proxy @Word8) (Proxy @(WordN 8)), + integralConformTest (Proxy @Word8) (Proxy @(WordN 8)), + testGroup + "WordN 8 conform to Word8 for Num instances" + [ testProperty "(+)" $ \x y -> ioProperty $ wordBinConform (+) (+) x y, + testProperty "(*)" $ \x y -> ioProperty $ wordBinConform (*) (*) x y, + testProperty "(-)" $ \x y -> ioProperty $ wordBinConform (-) (-) x y, + testProperty "negate" $ ioProperty . wordUnaryConform negate negate, + testProperty "abs" $ ioProperty . wordUnaryConform abs abs, + testProperty "signum" $ ioProperty . wordUnaryConform signum signum, + testProperty "fromInteger" $ + ioProperty . \(x :: Integer) -> + unWordN (fromInteger x :: WordN 8) @=? toInteger (fromInteger x :: Word8) + ], + testGroup + "WordN 8 conform to Word8 for Ord instances" + [ testProperty "(<=)" $ \(x :: Word8) y -> ioProperty $ x <= y @=? (fromIntegral x :: WordN 8) <= (fromIntegral y :: WordN 8) + ], + testGroup + "IntN 8 conform to Int8 for Bits instances" + [ testProperty "(.&.)" $ \x y -> ioProperty $ intBinConform (.&.) (.&.) x y, + testProperty "(.|.)" $ \x y -> ioProperty $ intBinConform (.|.) (.|.) x y, + testProperty "xor" $ \x y -> ioProperty $ intBinConform xor xor x y, + testProperty "complement" $ ioProperty . intUnaryConform complement complement, + testProperty "shift" $ \x y -> ioProperty $ intBinIntConform shift shift x y, + testProperty "rotate" $ \x y -> ioProperty $ intBinIntConform rotate rotate x y, + testCase "zeroBits" $ (zeroBits :: IntN 8) @=? 0, + testProperty "bit" $ ioProperty . intUnaryNonNegIntConform bit bit, + testProperty "setBit" $ \x y -> ioProperty $ intBinNonNegIntConform setBit setBit x y, + testProperty "clearBit" $ \x y -> ioProperty $ intBinNonNegIntConform clearBit clearBit x y, + testProperty "complementBit" $ \x y -> ioProperty $ intBinNonNegIntConform complementBit complementBit x y, + testProperty "testBit" $ \(x :: Int8) i -> i < 0 || testBit x i == testBit (fromIntegral x :: IntN 8) i, + testCase "bitSizeMaybe" $ bitSizeMaybe (0 :: IntN 8) @=? Just 8, + testCase "isSigned" $ isSigned (0 :: IntN 8) @=? True, + testProperty "shiftL" $ \x y -> ioProperty $ intBinNonNegIntConform shiftL shiftL x y, + testProperty "shiftR" $ \x y -> ioProperty $ intBinNonNegIntConform shiftR shiftR x y, + testProperty "rotateL" $ \x y -> ioProperty $ intBinNonNegIntConform rotateL rotateL x y, + testProperty "rotateR" $ \x y -> ioProperty $ intBinNonNegIntConform rotateR rotateR x y, + testProperty "popCount" $ ioProperty . \(x :: Int8) -> popCount x @=? popCount (fromIntegral x :: IntN 8) + ], + finiteBitsConformTest (Proxy @Int8) (Proxy @(IntN 8)) 8, + boundedConformTest (Proxy @Int8) (Proxy @(IntN 8)), + enumConformTest (Proxy @Int8) (Proxy @(IntN 8)), + realConformTest (Proxy @Int8) (Proxy @(IntN 8)), + integralConformTest (Proxy @Int8) (Proxy @(IntN 8)), + testGroup + "IntN 8 conform to Int8 for Num instances" + [ testProperty "(+)" $ \x y -> ioProperty $ intBinConform (+) (+) x y, + testProperty "(*)" $ \x y -> ioProperty $ intBinConform (*) (*) x y, + testProperty "(-)" $ \x y -> ioProperty $ intBinConform (-) (-) x y, + testProperty "negate" $ ioProperty . wordUnaryConform negate negate, + testProperty "abs" $ ioProperty . wordUnaryConform abs abs, + testProperty "signum" $ ioProperty . wordUnaryConform signum signum, + testProperty "fromInteger" $ + ioProperty . \(x :: Integer) -> + intN8eqint8 (fromInteger x :: IntN 8) (fromInteger x :: Int8) + ], + testGroup + "IntN 8 conform to IntN for Ord instances" + [ testProperty "(<=)" $ \(x :: Int8) y -> ioProperty $ (fromIntegral x :: IntN 8) <= (fromIntegral y :: IntN 8) @=? x <= y + ], + testGroup + "WordN bvops" + [ testProperty "bvconcat" $ \(x :: Integer) (y :: Integer) -> + ioProperty $ + bvconcat (fromInteger x :: WordN 5) (fromInteger y :: WordN 7) @=? fromInteger (x * 128 + y `mod` 128), + testProperty "bvzeroExtend" $ ioProperty . \(x :: Integer) -> bvzeroExtend (Proxy :: Proxy 12) (fromInteger x :: WordN 7) @=? fromInteger (x `mod` 128), + testCase "bvsignExtend" $ do + bvsignExtend (Proxy :: Proxy 12) (0 :: WordN 8) @=? 0 + bvsignExtend (Proxy :: Proxy 12) (1 :: WordN 8) @=? 1 + bvsignExtend (Proxy :: Proxy 12) (127 :: WordN 8) @=? 127 + bvsignExtend (Proxy :: Proxy 12) (128 :: WordN 8) @=? 3968 + bvsignExtend (Proxy :: Proxy 12) (255 :: WordN 8) @=? 4095, + testProperty "bvextend is bvzeroExtend" $ + ioProperty . \(x :: Integer) -> + bvextend (Proxy :: Proxy 12) (fromInteger x :: WordN 8) @=? bvzeroExtend (Proxy :: Proxy 12) (fromInteger x :: WordN 8), + testCase "bvselect" $ do + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b11100 :: WordN 8) @=? 0b11 + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b111000 :: WordN 8) @=? 0b111 + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b101000 :: WordN 8) @=? 0b101 + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b1010000 :: WordN 8) @=? 0b10 + ], + testGroup + "IntN bvops" + [ testProperty "bvconcat" $ \(x :: Integer) (y :: Integer) -> + ioProperty $ + bvconcat (fromInteger x :: IntN 5) (fromInteger y :: IntN 7) @=? fromInteger (x * 128 + y `mod` 128), + testProperty "bvzeroExtend" $ ioProperty . \(x :: Integer) -> bvzeroExtend (Proxy :: Proxy 12) (fromInteger x :: IntN 7) @=? fromInteger (x `mod` 128), + testCase "bvsignExtend" $ do + bvsignExtend (Proxy :: Proxy 12) (0 :: WordN 8) @=? 0 + bvsignExtend (Proxy :: Proxy 12) (1 :: WordN 8) @=? 1 + bvsignExtend (Proxy :: Proxy 12) (127 :: WordN 8) @=? 127 + bvsignExtend (Proxy :: Proxy 12) (128 :: WordN 8) @=? 3968 + bvsignExtend (Proxy :: Proxy 12) (255 :: WordN 8) @=? 4095, + testProperty "bvextend is bvsignExtend" $ + ioProperty . \(x :: Integer) -> + bvextend (Proxy :: Proxy 12) (fromInteger x :: IntN 8) @=? bvsignExtend (Proxy :: Proxy 12) (fromInteger x :: IntN 8), + testCase "bvselect" $ do + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b11100 :: IntN 8) @=? 0b11 + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b111000 :: IntN 8) @=? 0b111 + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b101000 :: IntN 8) @=? 0b101 + bvselect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b1010000 :: IntN 8) @=? 0b10 + ], + testGroup + "Regression" + [ testCase "division of min bound and minus one for signed bit vector should throw" $ do + shouldThrow "divMod" $ divMod (minBound :: IntN 8) (-1 :: IntN 8) + shouldThrow "div" $ div (minBound :: IntN 8) (-1 :: IntN 8) + shouldThrow "mod" $ mod (minBound :: IntN 8) (-1 :: IntN 8) + shouldThrow "quotRem" $ quotRem (minBound :: IntN 8) (-1 :: IntN 8) + shouldThrow "quot" $ quot (minBound :: IntN 8) (-1 :: IntN 8) + shouldThrow "rem" $ rem (minBound :: IntN 8) (-1 :: IntN 8) + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.IR.SymPrim.Data.Prim.BVTests where + +import Data.Proxy +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +import Test.Tasty +import Test.Tasty.HUnit + +bvTests :: TestTree +bvTests = + testGroup + "BVTests" + [ testGroup + "pevalBVSelectTerm" + [ testCase "On concrete" $ do + pevalBVSelectTerm + (Proxy @0) + (Proxy @1) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 0 + pevalBVSelectTerm + (Proxy @1) + (Proxy @1) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 1 + pevalBVSelectTerm + (Proxy @2) + (Proxy @1) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 1 + pevalBVSelectTerm + (Proxy @3) + (Proxy @1) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 0 + pevalBVSelectTerm + (Proxy @0) + (Proxy @2) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 2 + pevalBVSelectTerm + (Proxy @1) + (Proxy @2) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 3 + pevalBVSelectTerm + (Proxy @2) + (Proxy @2) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 1 + pevalBVSelectTerm + (Proxy @0) + (Proxy @3) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 6 + pevalBVSelectTerm + (Proxy @1) + (Proxy @3) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 3 + pevalBVSelectTerm + (Proxy @0) + (Proxy @4) + (conTerm 6 :: Term (WordN 4)) + @=? conTerm 6, + testCase "On symbolic" $ do + pevalBVSelectTerm + (Proxy @2) + (Proxy @1) + (ssymTerm "a" :: Term (WordN 4)) + @=? bvselectTerm (Proxy @2) (Proxy @1) (ssymTerm "a" :: Term (WordN 4)) + ], + testGroup + "Extension" + [ testCase "On concrete" $ do + pevalBVExtendTerm True (Proxy @6) (conTerm 15 :: Term (WordN 4)) + @=? (conTerm 63 :: Term (WordN 6)) + pevalBVExtendTerm False (Proxy @6) (conTerm 15 :: Term (WordN 4)) + @=? (conTerm 15 :: Term (WordN 6)) + pevalBVExtendTerm True (Proxy @6) (conTerm 15 :: Term (IntN 4)) + @=? (conTerm 63 :: Term (IntN 6)) + pevalBVExtendTerm False (Proxy @6) (conTerm 15 :: Term (IntN 4)) + @=? (conTerm 15 :: Term (IntN 6)), + testCase "On symbolic" $ do + pevalBVExtendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) + @=? bvextendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) + pevalBVExtendTerm False (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) + @=? bvextendTerm False (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) + ], + testGroup + "Concat" + [ testCase "On concrete" $ do + pevalBVConcatTerm (conTerm 3 :: Term (WordN 4)) (conTerm 5 :: Term (WordN 3)) + @=? conTerm 29 + pevalBVConcatTerm (conTerm 3 :: Term (IntN 4)) (conTerm 5 :: Term (IntN 3)) + @=? conTerm 29, + testCase "On symbolic" $ do + pevalBVConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 3)) + @=? bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 3)) + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.IR.SymPrim.Data.Prim.BitsTests where + +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +import Test.Tasty +import Test.Tasty.HUnit + +bitsTests :: TestTree +bitsTests = + testGroup + "BitsTests" + [ testGroup + "AndBits" + [ testCase "On both concrete" $ do + pevalAndBitsTerm + (conTerm 3 :: Term (WordN 4)) + (conTerm 5) + @=? conTerm 1, + testCase "On zeroBits" $ do + pevalAndBitsTerm + (conTerm 0 :: Term (WordN 4)) + (ssymTerm "a") + @=? conTerm 0 + pevalAndBitsTerm + (ssymTerm "a") + (conTerm 0 :: Term (WordN 4)) + @=? conTerm 0, + testCase "On all one bits" $ do + pevalAndBitsTerm + (conTerm 15 :: Term (WordN 4)) + (ssymTerm "a") + @=? ssymTerm "a" + pevalAndBitsTerm + (ssymTerm "a") + (conTerm 15 :: Term (WordN 4)) + @=? ssymTerm "a", + testCase "On symbolic" $ do + pevalAndBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? andBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ], + testGroup + "OrBits" + [ testCase "On both concrete" $ do + pevalOrBitsTerm + (conTerm 3 :: Term (WordN 4)) + (conTerm 5) + @=? conTerm 7, + testCase "On zeroBits" $ do + pevalOrBitsTerm + (conTerm 0 :: Term (WordN 4)) + (ssymTerm "a") + @=? ssymTerm "a" + pevalOrBitsTerm + (ssymTerm "a") + (conTerm 0 :: Term (WordN 4)) + @=? ssymTerm "a", + testCase "On all one bits" $ do + pevalOrBitsTerm + (conTerm 15 :: Term (WordN 4)) + (ssymTerm "a") + @=? conTerm 15 + pevalOrBitsTerm + (ssymTerm "a") + (conTerm 15 :: Term (WordN 4)) + @=? conTerm 15, + testCase "On symbolic" $ do + pevalOrBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? orBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ], + testGroup + "XorBits" + [ testCase "On both concrete" $ do + pevalXorBitsTerm + (conTerm 3 :: Term (WordN 4)) + (conTerm 5) + @=? conTerm 6, + testCase "On zeroBits" $ do + pevalXorBitsTerm + (conTerm 0 :: Term (WordN 4)) + (ssymTerm "a") + @=? ssymTerm "a" + pevalXorBitsTerm + (ssymTerm "a") + (conTerm 0 :: Term (WordN 4)) + @=? ssymTerm "a", + testCase "On all one bits" $ do + pevalXorBitsTerm + (conTerm 15 :: Term (WordN 4)) + (ssymTerm "a") + @=? pevalComplementBitsTerm (ssymTerm "a") + pevalXorBitsTerm + (ssymTerm "a") + (conTerm 15 :: Term (WordN 4)) + @=? pevalComplementBitsTerm (ssymTerm "a"), + testCase "On single complement" $ do + pevalXorBitsTerm + (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")) + pevalXorBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (pevalComplementBitsTerm $ ssymTerm "b") + @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both complement" $ do + pevalXorBitsTerm + (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4)) + (pevalComplementBitsTerm $ ssymTerm "b") + @=? pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On symbolic" $ do + pevalXorBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? xorBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ], + testGroup + "ComplementBits" + [ testCase "On concrete" $ do + pevalComplementBitsTerm (conTerm 5 :: Term (WordN 4)) @=? conTerm 10, + testCase "On complement" $ do + pevalComplementBitsTerm (pevalComplementBitsTerm (ssymTerm "a") :: Term (WordN 4)) @=? ssymTerm "a", + testCase "On symbolic" $ do + pevalComplementBitsTerm (ssymTerm "a" :: Term (WordN 4)) + @=? complementBitsTerm (ssymTerm "a" :: Term (WordN 4)) + ], + testGroup + "ShiftBits" + [ testCase "On concrete" $ do + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) (-5) @=? conTerm 0 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) (-4) @=? conTerm 0 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) (-3) @=? conTerm 1 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) (-2) @=? conTerm 3 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) (-1) @=? conTerm 7 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) 0 @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) 1 @=? conTerm 14 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) 2 @=? conTerm 12 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) 3 @=? conTerm 8 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) 4 @=? conTerm 0 + pevalShiftBitsTerm (conTerm 15 :: Term (WordN 4)) 5 @=? conTerm 0 + + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) (-5) @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) (-4) @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) (-3) @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) (-2) @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) (-1) @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) 0 @=? conTerm 15 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) 1 @=? conTerm 14 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) 2 @=? conTerm 12 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) 3 @=? conTerm 8 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) 4 @=? conTerm 0 + pevalShiftBitsTerm (conTerm 15 :: Term (IntN 4)) 5 @=? conTerm 0, + testCase "shift 0" $ do + pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 0 @=? ssymTerm "a" + pevalShiftBitsTerm (ssymTerm "a" :: Term (IntN 4)) 0 @=? ssymTerm "a", + testCase "shift left bitsize" $ do + pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 4 @=? conTerm 0 + pevalShiftBitsTerm (ssymTerm "a" :: Term (IntN 4)) 4 @=? conTerm 0 + pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 5 @=? conTerm 0 + pevalShiftBitsTerm (ssymTerm "a" :: Term (IntN 4)) 5 @=? conTerm 0, + testCase "shift same direction twice" $ do + pevalShiftBitsTerm (pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 1) 2 + @=? pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 3 + pevalShiftBitsTerm (pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) (-1)) (-2) + @=? pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) (-3), + testCase "shift symbolic" $ do + pevalShiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 2 + @=? shiftBitsTerm (ssymTerm "a" :: Term (WordN 4)) 2 + ], + testGroup + "Rotate" + [ testCase "On concrete" $ do + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) (-4) @=? conTerm 3 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) (-3) @=? conTerm 6 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) (-2) @=? conTerm 12 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) (-1) @=? conTerm 9 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) 0 @=? conTerm 3 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) 1 @=? conTerm 6 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) 2 @=? conTerm 12 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) 3 @=? conTerm 9 + pevalRotateBitsTerm (conTerm 3 :: Term (WordN 4)) 4 @=? conTerm 3, + testCase "rotate 0" $ do + pevalRotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) 0 @=? ssymTerm "a", + testCase "rotate extra bits" $ do + pevalRotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) 4 @=? ssymTerm "a" + pevalRotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) 5 + @=? pevalRotateBitsTerm (ssymTerm "a") 1 + pevalRotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) (-1) + @=? pevalRotateBitsTerm (ssymTerm "a") 3, + testCase "rotate twice" $ do + pevalRotateBitsTerm (pevalRotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) 1) 2 + @=? pevalRotateBitsTerm (ssymTerm "a") 3, + testCase "rotate symbolic" $ do + pevalRotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) 2 + @=? rotateBitsTerm (ssymTerm "a" :: Term (WordN 4)) 2 + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.IR.SymPrim.Data.Prim.BoolTests where + +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Test.Tasty +import Test.Tasty.HUnit + +boolTests :: TestTree +boolTests = + testGroup + "BoolTests" + [ testGroup + "Not" + [ testCase "On concrete" $ do + pevalNotTerm (conTerm True) @=? conTerm False + pevalNotTerm (conTerm True) @=? conTerm False, + testCase "On general symbolic" $ do + pevalNotTerm (ssymTerm "a") @=? notTerm (ssymTerm "a" :: Term Bool), + testCase "On Not" $ do + pevalNotTerm (pevalNotTerm (ssymTerm "a")) @=? ssymTerm "a", + testCase "On Or Not" $ do + pevalNotTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) + pevalNotTerm (pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) + @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"), + testCase "On And Not" $ do + pevalNotTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) + pevalNotTerm (pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) + @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + ], + testGroup + "Eqv & NEqv" + [ testCase "Eqv on both concrete" $ do + pevalEqvTerm (conTerm True) (conTerm True) @=? conTerm True + pevalEqvTerm (conTerm True) (conTerm False) @=? conTerm False + pevalEqvTerm (conTerm False) (conTerm True) @=? conTerm False + pevalEqvTerm (conTerm False) (conTerm False) @=? conTerm True + pevalEqvTerm (conTerm (1 :: Integer)) (conTerm 1) @=? conTerm True + pevalEqvTerm (conTerm (1 :: Integer)) (conTerm 2) @=? conTerm False + pevalEqvTerm (conTerm (1 :: IntN 4)) (conTerm 1) @=? conTerm True + pevalEqvTerm (conTerm (1 :: IntN 4)) (conTerm 2) @=? conTerm False + pevalEqvTerm (conTerm (1 :: WordN 4)) (conTerm 1) @=? conTerm True + pevalEqvTerm (conTerm (1 :: WordN 4)) (conTerm 2) @=? conTerm False, + testCase "Eqv on single concrete always put concrete ones in the right" $ do + pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + @=? eqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer) + pevalEqvTerm (conTerm 1) (ssymTerm "a" :: Term Integer) + @=? eqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer), + testCase "Eqv on general symbolic" $ do + pevalEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? eqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + testCase "Eqv on Bool with single concrete" $ do + pevalEqvTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" + pevalEqvTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" + pevalEqvTerm (conTerm False) (ssymTerm "a") @=? pevalNotTerm (ssymTerm "a") + pevalEqvTerm (ssymTerm "a") (conTerm False) @=? pevalNotTerm (ssymTerm "a"), + testCase "NEqv on general symbolic" $ do + pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalNotTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")), + testCase "Eqv(Not(x), x) / Eqv(x, Not(x))" $ do + pevalEqvTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False + pevalEqvTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, + testCase "Eqv(n1+x, n2)" $ do + pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) (conTerm 3) + @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term Integer) + pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) (conTerm 3) + @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) + pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) (conTerm 3) + @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), + testCase "Eqv(n1, n2+x)" $ do + pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) + @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term Integer) + pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) + @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) + pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) + @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), + testCase "Eqv(l, ITE(c, l, f)) / Eqv(l, ITE(c, t, l) / Eqv(ITE(c, r, f), r) / Eqv(ITE(c, t, r), r)" $ do + pevalEqvTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) + @=? pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) + pevalEqvTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqvTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) + pevalEqvTerm (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) (ssymTerm "a" :: Term Integer) + @=? pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) + pevalEqvTerm (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) (ssymTerm "a" :: Term Integer) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqvTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) + ], + testGroup + "Or" + [ testCase "On both concrete" $ do + pevalOrTerm (conTerm True) (conTerm True) @=? conTerm True + pevalOrTerm (conTerm True) (conTerm False) @=? conTerm True + pevalOrTerm (conTerm False) (conTerm True) @=? conTerm True + pevalOrTerm (conTerm False) (conTerm False) @=? conTerm False, + testCase "On general symbolic" $ do + pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @=? orTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), + testCase "Or(x, y) -> True" $ do + pevalOrTerm (conTerm True) (ssymTerm "b") @=? conTerm True + pevalOrTerm (ssymTerm "a") (conTerm True) @=? conTerm True + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? conTerm True + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm True + pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm True, + testCase "Or(x, y) -> x" $ do + pevalOrTerm (ssymTerm "a") (conTerm False) @=? ssymTerm "a" + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", + testCase "Or(x, y) -> y" $ do + pevalOrTerm (conTerm False) (ssymTerm "a") @=? ssymTerm "a" + pevalOrTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "Or(x, Or(y1, y2)) -> True" $ do + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm True + pevalOrTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm True + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? conTerm True + + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm True + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm True + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? conTerm True, + testCase "Or(x, Or(y1, y2)) -> Or(x, y2)" $ do + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(x, Or(y1, y2)) -> Or(x, y1)" $ do + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(x, y@Or(y1, y2)) -> y" $ do + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") + pevalOrTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(Or(x1, x2), y) -> True" $ do + pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True + pevalOrTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm True + pevalOrTerm + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm True + + pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True + pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm True + pevalOrTerm + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm True, + testCase "Or(x@Or(x1, x2), y) -> x" $ do + pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") + @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") + pevalOrTerm + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(Or(x1, x2), y) -> Or(x2, y)" $ do + pevalOrTerm + (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(Or(x1, x2), y) -> Or(x1, y)" $ do + pevalOrTerm + (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(x, And(y1, y2)) -> x" $ do + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "Or(x, And(y1, y2)) -> Or(x, y2)" $ do + pevalOrTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(And(x1, x2), y) -> y" $ do + pevalOrTerm + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "Or(x, And(y1, y2)) -> Or(x, y1)" $ do + pevalOrTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalOrTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(Not(x), Not(y)) -> Not(And(x, y))" $ do + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) + @=? pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + ], + testGroup + "And" + [ testCase "Oith both concrete" $ do + pevalAndTerm (conTerm True) (conTerm True) @=? conTerm True + pevalAndTerm (conTerm True) (conTerm False) @=? conTerm False + pevalAndTerm (conTerm False) (conTerm True) @=? conTerm False + pevalAndTerm (conTerm False) (conTerm False) @=? conTerm False, + testCase "On general symbolic" $ do + pevalAndTerm (ssymTerm "a") (ssymTerm "b") + @=? andTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), + testCase "And(x, y) -> False" $ do + pevalAndTerm (conTerm False) (ssymTerm "b") @=? conTerm False + pevalAndTerm (ssymTerm "a") (conTerm False) @=? conTerm False + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? conTerm False + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False + pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, + testCase "And(x, y) -> x" $ do + pevalAndTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", + testCase "And(x, y) -> y" $ do + pevalAndTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" + pevalAndTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "And(x, And(y1, y2)) -> False" $ do + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm False + pevalAndTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm False + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? conTerm False + + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm False + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm False + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? conTerm False, + testCase "And(x, And(y1, y2)) -> And(x, y2)" $ do + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(x, And(y1, y2)) -> And(x, y1)" $ do + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(x, y@And(y1, y2)) -> y" $ do + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") + pevalAndTerm + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(And(x1, x2), y) -> False" $ do + pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False + pevalAndTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm False + pevalAndTerm + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm False + + pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False + pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm False + pevalAndTerm + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm False, + testCase "And(x@And(x1, x2), y) -> x" $ do + pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") + @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") + pevalAndTerm + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(And(x1, x2), y) -> And(x2, y)" $ do + pevalAndTerm + (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(And(x1, x2), y) -> And(x1, y)" $ do + pevalAndTerm + (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(x, Or(y1, y2)) -> x" $ do + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "And(x, Or(y1, y2)) -> And(x, y2)" $ do + pevalAndTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(Or(x1, x2), y) -> y" $ do + pevalAndTerm + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "And(x, Or(y1, y2)) -> And(x, y1)" $ do + pevalAndTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalAndTerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(Not(x), Not(y)) -> Not(Or(x, y))" $ do + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) + @=? pevalNotTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + ], + testGroup + "ITE" + [ testCase "On concrete condition" $ do + pevalITETerm (conTerm True) (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? ssymTerm "a" + pevalITETerm (conTerm False) (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? ssymTerm "b", + testCase "On same branches" $ do + pevalITETerm (ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "a") + @=? ssymTerm "a", + testCase "On both not" $ do + pevalITETerm (ssymTerm "c") (pevalNotTerm $ ssymTerm "a") (pevalNotTerm $ ssymTerm "b") + @=? pevalNotTerm (pevalITETerm (ssymTerm "c") (ssymTerm "a") (ssymTerm "b")), + testCase "On not in condition" $ do + pevalITETerm (pevalNotTerm $ ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalITETerm (ssymTerm "c") (ssymTerm "b") (ssymTerm "a"), + testCase "On all arguments as ITE with same conditions" $ do + pevalITETerm + (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) + (pevalITETerm (ssymTerm "a") (ssymTerm "d" :: Term Integer) (ssymTerm "e")) + (pevalITETerm (ssymTerm "a") (ssymTerm "f" :: Term Integer) (ssymTerm "g")) + @=? pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "b") (ssymTerm "d") (ssymTerm "f")) + (pevalITETerm (ssymTerm "c") (ssymTerm "e") (ssymTerm "g")), + testCase "On with true branch as ITE" $ do + pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) (ssymTerm "c")) + (ssymTerm "d") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) + (ssymTerm "c") + @=? pevalITETerm + (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) + (ssymTerm "d") + @=? pevalITETerm + (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + (ssymTerm "d"), + testCase "On false branch as ITE" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalITETerm (ssymTerm "a") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalITETerm (ssymTerm "c") (ssymTerm "b" :: Term Integer) (ssymTerm "d")) + @=? pevalITETerm + (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) + (ssymTerm "b") + (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalITETerm (ssymTerm "c") (ssymTerm "d" :: Term Integer) (ssymTerm "b")) + @=? pevalITETerm + (pevalOrTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "c")) + (ssymTerm "b") + (ssymTerm "d"), + testCase "On both And" $ do + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) + (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) + (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), + testCase "On left And" $ do + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "b") + @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "c") + @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) + (ssymTerm "c") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"), + testCase "On right And" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (ssymTerm "c") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both Or" $ do + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) + (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) + (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), + testCase "On left Or" $ do + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "b") + @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (ssymTerm "a") (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c"), + testCase "On right Or" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (ssymTerm "c") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")), + testCase "On const boolean in branches" $ do + pevalITETerm + (ssymTerm "a") + (conTerm True) + (ssymTerm "b") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (conTerm False) + (ssymTerm "b") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (conTerm True) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (conTerm False) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On condition equal to some branch" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "a") + (ssymTerm "b") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (ssymTerm "a") + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On left Not" $ do + pevalITETerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), + testCase "On right Not" $ do + pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalNotTerm (ssymTerm "a")) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), + testCase "On left Not And" $ do + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a"))) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + ], + testGroup + "Imply" + [ testCase "pevalImplyTerm" $ do + ssymTerm "a" + `pevalImplyTerm` ssymTerm "b" + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + ], + testGroup + "Xor" + [ testCase "pevalXorTerm" $ do + ssymTerm "a" + `pevalXorTerm` ssymTerm "b" + @=? pevalOrTerm + (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (pevalAndTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b")) + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/IntegerTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/IntegerTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/IntegerTests.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.IR.SymPrim.Data.Prim.IntegerTests where + +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +integerTests :: TestTree +integerTests = + testGroup + "IntegerTests" + [ testGroup + "DivI" + [ testProperty "On concrete" $ + ioProperty . \(i :: Integer, j :: Integer) -> do + if j /= 0 + then pevalDivIntegerTerm (conTerm i) (conTerm j) @=? conTerm (i `div` j) + else + pevalDivIntegerTerm (conTerm i) (conTerm j) + @=? divIntegerTerm (conTerm i) (conTerm j), + testCase "divide by 1" $ do + pevalDivIntegerTerm (ssymTerm "a" :: Term Integer) (conTerm 1) @=? ssymTerm "a", + testCase "On symbolic" $ do + pevalDivIntegerTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? divIntegerTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) + ], + testGroup + "ModI" + [ testProperty "On concrete" $ + ioProperty . \(i :: Integer, j :: Integer) -> do + if j /= 0 + then pevalModIntegerTerm (conTerm i) (conTerm j) @=? conTerm (i `mod` j) + else + pevalModIntegerTerm (conTerm i) (conTerm j) + @=? modIntegerTerm (conTerm i) (conTerm j), + testCase "mod by 1" $ do + pevalModIntegerTerm (ssymTerm "a" :: Term Integer) (conTerm 1) @=? conTerm 0, + testCase "mod by -1" $ do + pevalModIntegerTerm (ssymTerm "a" :: Term Integer) (conTerm $ -1) @=? conTerm 0, + testCase "On symbolic" $ do + pevalModIntegerTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? modIntegerTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.IR.SymPrim.Data.Prim.ModelTests where + +import Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Grisette.Core.Data.Class.ModelOps +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.Model as Model +import Grisette.IR.SymPrim.Data.Prim.ModelValue +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Test.Tasty +import Test.Tasty.HUnit +import Type.Reflection + +modelTests :: TestTree +modelTests = + let asymbol :: TypedSymbol Integer = SimpleSymbol "a" + bsymbol :: TypedSymbol Bool = SimpleSymbol "b" + csymbol :: TypedSymbol Integer = SimpleSymbol "c" + dsymbol :: TypedSymbol Bool = SimpleSymbol "d" + esymbol :: TypedSymbol (WordN 4) = SimpleSymbol "e" + fsymbol :: TypedSymbol (IntN 4) = SimpleSymbol "f" + gsymbol :: TypedSymbol (WordN 16) = SimpleSymbol "g" + hsymbol :: TypedSymbol (IntN 16) = SimpleSymbol "h" + m1 = emptyModel + m2 = insertValue asymbol 1 m1 + m3 = insertValue bsymbol True m2 + in testGroup + "ModelTests" + [ testCase "empty model is really empty" $ do + emptyModel @=? Model M.empty, + testCase "inserting to model" $ do + m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True) + ] + ), + testCase "equation" $ do + equation asymbol m3 @=? Just (pevalEqvTerm (ssymTerm "a") (conTerm 1 :: Term Integer)) + equation bsymbol m3 @=? Just (pevalEqvTerm (ssymTerm "b") (conTerm True)) + equation csymbol m3 @=? Nothing, + testCase "valueOf" $ do + valueOf asymbol m3 @=? Just (1 :: Integer) + valueOf bsymbol m3 @=? Just True + valueOf csymbol m3 @=? (Nothing :: Maybe Integer), + testCase "exceptFor" $ do + exceptFor (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3 + @=? Model + ( M.fromList + [ (someTypedSymbol bsymbol, toModelValue True) + ] + ), + testCase "restrictTo" $ do + restrictTo (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)) + ] + ), + testCase "extendTo" $ do + extendTo + ( SymbolSet $ + S.fromList + [ someTypedSymbol csymbol, + someTypedSymbol dsymbol, + someTypedSymbol esymbol, + someTypedSymbol fsymbol + ] + ) + m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (0 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (0 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (0 :: IntN 4)) + ] + ), + testCase "exact" $ do + exact + ( SymbolSet $ + S.fromList + [ someTypedSymbol asymbol, + someTypedSymbol csymbol + ] + ) + m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol csymbol, toModelValue (0 :: Integer)) + ] + ), + testCase "evaluateTerm" $ do + evaluateTerm False m3 (conTerm (1 :: Integer)) @=? conTerm 1 + evaluateTerm True m3 (conTerm (1 :: Integer)) @=? conTerm 1 + evaluateTerm False m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1 + evaluateTerm True m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1 + evaluateTerm False m3 (ssymTerm "x" :: Term Integer) @=? ssymTerm "x" + evaluateTerm True m3 (ssymTerm "x" :: Term Integer) @=? conTerm 0 + evaluateTerm False m3 (ssymTerm "y" :: Term Bool) @=? ssymTerm "y" + evaluateTerm True m3 (ssymTerm "y" :: Term Bool) @=? conTerm False + evaluateTerm False m3 (ssymTerm "z" :: Term (WordN 4)) @=? ssymTerm "z" + evaluateTerm True m3 (ssymTerm "z" :: Term (WordN 4)) @=? conTerm 0 + evaluateTerm False m3 (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1) + evaluateTerm True m3 (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1) + evaluateTerm False m3 (pevalUMinusNumTerm $ ssymTerm "x" :: Term Integer) @=? pevalUMinusNumTerm (ssymTerm "x") + evaluateTerm True m3 (pevalUMinusNumTerm $ ssymTerm "x" :: Term Integer) @=? conTerm 0 + evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2 + evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2 + evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? pevalAddNumTerm (conTerm 1) (ssymTerm "x") + evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? conTerm 1 + evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") + evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? conTerm 0 + evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? conTerm 2 + evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? conTerm 2 + evaluateTerm False m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? pevalITETerm (ssymTerm "x") (conTerm 2) (conTerm 1) + evaluateTerm True m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? conTerm 1 + evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? ssymTerm "x" + evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? conTerm 0 + evaluateTerm False m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) + evaluateTerm True m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? conTerm 1, + testCase "construction from ModelValuePair" $ do + buildModel (asymbol ::= 1) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue (1 :: Integer))) + buildModel (asymbol ::= 1, bsymbol ::= True) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3, + fsymbol ::= 4 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3, + fsymbol ::= 4, + gsymbol ::= 5 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), + (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3, + fsymbol ::= 4, + gsymbol ::= 5, + hsymbol ::= 6 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), + (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)), + (someTypedSymbol hsymbol, toModelValue (6 :: IntN 16)) + ] + ) + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.IR.SymPrim.Data.Prim.NumTests where + +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Test.Tasty +import Test.Tasty.HUnit + +numTests :: TestTree +numTests = + testGroup + "NumTests" + [ testGroup + "Add" + [ testCase "On concrete" $ do + pevalAddNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm 3 + pevalAddNumTerm (conTerm 1 :: Term (WordN 3)) (conTerm 2) @=? conTerm 3 + pevalAddNumTerm (conTerm 1 :: Term (IntN 3)) (conTerm 2) @=? conTerm 3, + testCase "On left 0" $ do + pevalAddNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") @=? ssymTerm "a", + testCase "On right 0" $ do + pevalAddNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) @=? ssymTerm "a", + testCase "On left concrete" $ do + pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a") + @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer), + testCase "On right concrete" $ do + pevalAddNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer), + testCase "On no concrete" $ do + pevalAddNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) + @=? addNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + testCase "On left concrete and right add concrete value" $ do + pevalAddNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) + @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"), + testCase "On right concrete and left add concrete value" $ do + pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (conTerm 1 :: Term Integer) + @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"), + testCase "On left add concrete" $ do + pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (ssymTerm "b") + @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right add concrete" $ do + pevalAddNumTerm (ssymTerm "b") (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) + @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (ssymTerm "a")), + testCase "On both uminus" $ do + pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "b") + @=? pevalUMinusNumTerm (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both times the same concrete" $ do + pevalAddNumTerm + (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) + (pevalTimesNumTerm (conTerm 3) (ssymTerm "b")) + @=? pevalTimesNumTerm (conTerm 3) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both times the same symbolic" $ do + pevalAddNumTerm + (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) + (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")) + @=? pevalTimesNumTerm (conTerm 6) (ssymTerm "a") + pevalAddNumTerm + (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) + (pevalTimesNumTerm (conTerm 4) (ssymTerm "a")) + @=? pevalTimesNumTerm (conTerm 7) (ssymTerm "a"), + testCase "Unfold 1" $ do + pevalAddNumTerm + (conTerm 3) + (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a")) + @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (conTerm 3) (ssymTerm "a")) + pevalAddNumTerm + (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a")) + (conTerm 3) + @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (ssymTerm "a") (conTerm 3)) + ], + testGroup + "minus" + [ testCase "minus num should be delegated to add and uminus" $ do + pevalMinusNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b") + ], + testGroup + "UMinus" + [ testCase "On concrete" $ do + pevalUMinusNumTerm (conTerm 1 :: Term Integer) @=? conTerm (-1) + pevalUMinusNumTerm (conTerm 1 :: Term (WordN 3)) @=? conTerm (-1), + testCase "On UMinus" $ do + pevalUMinusNumTerm (pevalUMinusNumTerm (ssymTerm "a" :: Term Integer)) @=? ssymTerm "a", + testCase "On Add concrete" $ do + pevalUMinusNumTerm (pevalAddNumTerm (conTerm 1) (ssymTerm "a" :: Term Integer)) + @=? pevalAddNumTerm (conTerm $ -1) (pevalUMinusNumTerm $ ssymTerm "a"), + testCase "On Add uminus" $ do + pevalUMinusNumTerm (pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer)) + @=? pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b") + pevalUMinusNumTerm (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b" :: Term Integer)) + @=? pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b"), + testCase "On Times concrete" $ do + pevalUMinusNumTerm (pevalTimesNumTerm (conTerm 3) (ssymTerm "a" :: Term Integer)) + @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"), + testCase "On symbolic" $ do + pevalUMinusNumTerm (ssymTerm "a" :: Term Integer) + @=? uminusNumTerm (ssymTerm "a") + ], + testGroup + "Times" + [ testCase "On both concrete" $ do + pevalTimesNumTerm (conTerm 3 :: Term Integer) (conTerm 5) + @=? conTerm 15, + testCase "On left 0" $ do + pevalTimesNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") + @=? conTerm 0, + testCase "On right 0" $ do + pevalTimesNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) + @=? conTerm 0, + testCase "On left 1" $ do + pevalTimesNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a") + @=? ssymTerm "a", + testCase "On right 1" $ do + pevalTimesNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? ssymTerm "a", + testCase "On left -1" $ do + pevalTimesNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a") + @=? pevalUMinusNumTerm (ssymTerm "a"), + testCase "On right -1" $ do + pevalTimesNumTerm (ssymTerm "a") (conTerm $ -1 :: Term Integer) + @=? pevalUMinusNumTerm (ssymTerm "a"), + testCase "On left concrete and right times concrete symbolics" $ do + pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) + @=? pevalTimesNumTerm (conTerm 15) (ssymTerm "a"), + testCase "On right concrete and left times concrete symbolics" $ do + pevalTimesNumTerm (pevalTimesNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3) + @=? pevalTimesNumTerm (conTerm 15) (ssymTerm "a"), + testCase "On left concrete and right add concrete symbolics" $ do + pevalTimesNumTerm (conTerm 3) (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) + @=? pevalAddNumTerm (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")), + testCase "On right concrete and left add concrete symbolics" $ do + pevalTimesNumTerm (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3) + @=? pevalAddNumTerm (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")), + testCase "On left concrete and right uminus" $ do + pevalTimesNumTerm (conTerm 3 :: Term Integer) (pevalUMinusNumTerm (ssymTerm "a")) + @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"), + testCase "On left times concrete symbolics" $ do + pevalTimesNumTerm (pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) (ssymTerm "b") + @=? pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right times concrete symbolics" $ do + pevalTimesNumTerm (ssymTerm "b") (pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) + @=? pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (ssymTerm "b") (ssymTerm "a")), + testCase "On left uminus" $ do + pevalTimesNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer) + @=? pevalUMinusNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right uminus" $ do + pevalTimesNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b" :: Term Integer) + @=? pevalUMinusNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right concrete and left uminus" $ do + pevalTimesNumTerm (pevalUMinusNumTerm (ssymTerm "a")) (conTerm 3 :: Term Integer) + @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"), + testCase "On left concrete" $ do + pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a") + @=? timesNumTerm + (conTerm 3 :: Term Integer) + (ssymTerm "a" :: Term Integer), + testCase "On right concrete" $ do + pevalTimesNumTerm (ssymTerm "a") (conTerm 3 :: Term Integer) + @=? timesNumTerm + (conTerm 3 :: Term Integer) + (ssymTerm "a" :: Term Integer), + testCase "On no concrete" $ do + pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) + @=? timesNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + testCase "Unfold 1" $ do + pevalTimesNumTerm + (conTerm 3) + (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a")) + @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")) + pevalTimesNumTerm + (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a")) + (conTerm 3) + @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalTimesNumTerm (ssymTerm "a") (conTerm 3)) + ], + testGroup + "Abs" + [ testCase "On concrete" $ do + pevalAbsNumTerm (conTerm 10 :: Term Integer) @=? conTerm 10 + pevalAbsNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm 10, + testCase "On UMinus" $ do + pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"), + testCase "On Abs" $ do + pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"), + testCase "On Times Integer" $ do + pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer) + @=? pevalTimesNumTerm (pevalAbsNumTerm (ssymTerm "a")) (pevalAbsNumTerm (ssymTerm "b")), + testCase "On Times BV" $ do + pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + @=? absNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)) + @=? absNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)), + testCase "On symbolic" $ do + pevalAbsNumTerm (ssymTerm "a" :: Term Integer) + @=? absNumTerm (ssymTerm "a") + ], + testGroup + "Signum" + [ testCase "On concrete" $ do + pevalSignumNumTerm (conTerm 10 :: Term Integer) @=? conTerm 1 + pevalSignumNumTerm (conTerm 0 :: Term Integer) @=? conTerm 0 + pevalSignumNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm (-1), + testCase "On UMinus Integer" $ do + pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) + @=? pevalUMinusNumTerm (pevalSignumNumTerm $ ssymTerm "a"), + testCase "On UMinus BV" $ do + pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) + @=? signumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) + pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) + @=? signumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)), + testCase "On Times Integer" $ do + pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer) + @=? pevalTimesNumTerm (pevalSignumNumTerm $ ssymTerm "a") (pevalSignumNumTerm $ ssymTerm "b"), + testCase "On Times BV" $ do + pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + @=? signumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)) + @=? signumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)), + testCase "On symbolics" $ do + pevalSignumNumTerm (ssymTerm "a" :: Term Integer) + @=? signumNumTerm (ssymTerm "a") + ], + let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger + concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger + in testGroup + "Lt" + [ testCase "On both concrete" $ do + pevalLtNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True + pevalLtNumTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm False + pevalLtNumTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False + pevalLtNumTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False + pevalLtNumTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLtNumTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLtNumTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True + pevalLtNumTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm False + pevalLtNumTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False, + testCase "On left constant and right add concrete Integers" $ do + pevalLtNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On right constant left add concrete Integers" $ do + pevalLtNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer) + @=? pevalLtNumTerm (conTerm 1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), + testCase "On right constant Integers" $ do + pevalLtNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), + testCase "On right constant and left uminus Integers" $ do + pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On left add concrete Integers" $ do + pevalLtNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer) + @=? pevalLtNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalUMinusNumTerm $ ssymTerm "a")), + testCase "On right add concrete Integers" $ do + pevalLtNumTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLtNumTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")), + testCase "On left constant and right add concrete BVs should not be simplified" $ do + pevalLtNumTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? ltNumTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLtNumTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? ltNumTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On right constant and left add concrete BVs should not be simplified" $ do + pevalLtNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? ltNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1) + pevalLtNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? ltNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1), + testCase "On right constant BVs should not be simplified" $ do + pevalLtNumTerm (ssymTerm "a") (concSignedBV 1) + @=? ltNumTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLtNumTerm (ssymTerm "a") (concUnsignedBV 1) + @=? ltNumTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On right constant and left uminus BVs should not be simplified" $ do + pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concSignedBV 1) + @=? ltNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concUnsignedBV 1) + @=? ltNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On left add concrete BVs should not be simplified" $ do + pevalLtNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? ltNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5)) + pevalLtNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? ltNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)), + testCase "On right add concrete BVs should not be simplified" $ do + pevalLtNumTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + @=? ltNumTerm + (ssymTerm "b" :: Term (IntN 5)) + (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLtNumTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) + @=? ltNumTerm + (ssymTerm "b" :: Term (WordN 5)) + (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On symbolic" $ do + pevalLtNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? ltNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) + ], + let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger + concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger + in testGroup + "Le" + [ testCase "On both concrete" $ do + pevalLeNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True + pevalLeNumTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm True + pevalLeNumTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False + pevalLeNumTerm (conTerm 0 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLeNumTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False + pevalLeNumTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLeNumTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLeNumTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True + pevalLeNumTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm True + pevalLeNumTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False, + testCase "On left constant and right add concrete Integers" $ do + pevalLeNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On right constant and left add concrete Integers" $ do + pevalLeNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer) + @=? pevalLeNumTerm (conTerm 1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), + testCase "On right constant Integers" $ do + pevalLeNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), + testCase "On right constant left uminus Integers" $ do + pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On left add concrete Integers" $ do + pevalLeNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer) + @=? pevalLeNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalUMinusNumTerm $ ssymTerm "a")), + testCase "On right add concrete Integers" $ do + pevalLeNumTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLeNumTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")), + testCase "On left constant and right add concrete BVs should not be simplified" $ do + pevalLeNumTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? leNumTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLeNumTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? leNumTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On right constant and left add concrete BVs should not be simplified" $ do + pevalLeNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? leNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1) + pevalLeNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? leNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1), + testCase "On right constant BVs should not be simplified" $ do + pevalLeNumTerm (ssymTerm "a") (concSignedBV 1) + @=? leNumTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLeNumTerm (ssymTerm "a") (concUnsignedBV 1) + @=? leNumTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On right constant and left uminus BVs should not be simplified" $ do + pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concSignedBV 1) + @=? leNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concUnsignedBV 1) + @=? leNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On left add concrete BVs should not be simplified" $ do + pevalLeNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? leNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5)) + pevalLeNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? leNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)), + testCase "Lt on right add concrete BVs should not be simplified" $ do + pevalLeNumTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + @=? leNumTerm + (ssymTerm "b" :: Term (IntN 5)) + (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLeNumTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) + @=? leNumTerm + (ssymTerm "b" :: Term (WordN 5)) + (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On symbolic" $ do + pevalLeNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? leNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) + ], + testCase "Gt should be delegated to Lt" $ + pevalGtNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalLtNumTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a"), + testCase "Ge should be delegated to Le" $ do + pevalGeNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalLeNumTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a") + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.IR.SymPrim.Data.Prim.TabularFunTests where + +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +import Grisette.IR.SymPrim.Data.TabularFun +import Test.Tasty +import Test.Tasty.HUnit + +tabularFunTests :: TestTree +tabularFunTests = + testGroup + "TabularFunTests" + [ testGroup + "ApplyF" + [ testCase "On concrete" $ do + let f :: Integer =-> Integer = + TabularFun [(1, 2), (3, 4)] 5 + pevalTabularFunApplyTerm (conTerm f) (conTerm 0) @=? conTerm 5 + pevalTabularFunApplyTerm (conTerm f) (conTerm 1) @=? conTerm 2 + pevalTabularFunApplyTerm (conTerm f) (conTerm 2) @=? conTerm 5 + pevalTabularFunApplyTerm (conTerm f) (conTerm 3) @=? conTerm 4 + pevalTabularFunApplyTerm (conTerm f) (conTerm 4) @=? conTerm 5, + testCase "On concrete function" $ do + let f :: Integer =-> Integer = + TabularFun [(1, 2), (3, 4)] 5 + pevalTabularFunApplyTerm (conTerm f) (ssymTerm "b") + @=? pevalITETerm + (pevalEqvTerm (conTerm 1 :: Term Integer) (ssymTerm "b")) + (conTerm 2) + ( pevalITETerm + (pevalEqvTerm (conTerm 3 :: Term Integer) (ssymTerm "b")) + (conTerm 4) + (conTerm 5) + ), + testCase "On symbolic" $ do + pevalTabularFunApplyTerm (ssymTerm "f" :: Term (Integer =-> Integer)) (ssymTerm "a") + @=? tabularFunApplyTerm + (ssymTerm "f" :: Term (Integer =-> Integer)) + (ssymTerm "a" :: Term Integer) + ] + ] diff --git a/test/Grisette/IR/SymPrim/Data/SymPrimTests.hs b/test/Grisette/IR/SymPrim/Data/SymPrimTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/SymPrimTests.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Grisette.IR.SymPrim.Data.SymPrimTests where + +import Control.Monad.Except +import Data.Bits +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Int +import Data.Proxy +import Data.Word +import Grisette.Core.Control.Monad.UnionM +import Grisette.Core.Data.Class.BitVector +import Grisette.Core.Data.Class.Bool +import Grisette.Core.Data.Class.Evaluate +import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Core.Data.Class.Function +import Grisette.Core.Data.Class.GenSym +import Grisette.Core.Data.Class.Integer +import Grisette.Core.Data.Class.Mergeable +import Grisette.Core.Data.Class.ModelOps +import Grisette.Core.Data.Class.SOrd +import Grisette.Core.Data.Class.SimpleMergeable +import Grisette.Core.Data.Class.Solvable +import Grisette.Core.Data.Class.ToCon +import Grisette.Core.Data.Class.ToSym +import Grisette.IR.SymPrim.Data.BV +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors +import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term +import Grisette.IR.SymPrim.Data.Prim.Model +import Grisette.IR.SymPrim.Data.Prim.ModelValue +import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integer +import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num +import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun +import Grisette.IR.SymPrim.Data.SymPrim +import Grisette.IR.SymPrim.Data.TabularFun +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck hiding ((.&.)) +import Type.Reflection hiding (Con) + +symPrimTests :: TestTree +symPrimTests = + testGroup + "SymPrimTests" + [ testGroup + "General SymPrim" + [ testGroup + "Solvable" + [ testCase "con" $ do + (con 1 :: Sym Integer) @=? Sym (conTerm 1), + testCase "ssym" $ do + (ssym "a" :: Sym Integer) @=? Sym (ssymTerm "a"), + testCase "isym" $ do + (isym "a" 1 :: Sym Integer) @=? Sym (isymTerm "a" 1), + testCase "conView" $ do + conView (con 1 :: Sym Integer) @=? Just 1 + conView (ssym "a" :: Sym Integer) @=? Nothing + case con 1 :: Sym Integer of + Con 1 -> return () + _ -> assertFailure "Bad match" + case ssym "a" :: Sym Integer of + Con _ -> assertFailure "Bad match" + _ -> return () + ], + testGroup + "ITEOp" + [ testCase "ites" $ + ites (ssym "a" :: Sym Bool) (ssym "b" :: Sym Integer) (ssym "c") + @=? Sym (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) + ], + testCase "Mergeable" $ do + let SimpleStrategy s = rootStrategy :: MergingStrategy (Sym Integer) + s (ssym "a") (ssym "b") (ssym "c") + @=? ites (ssym "a" :: Sym Bool) (ssym "b" :: Sym Integer) (ssym "c"), + testCase "SimpleMergeable" $ do + mrgIte (ssym "a" :: Sym Bool) (ssym "b") (ssym "c") + @=? ites (ssym "a" :: Sym Bool) (ssym "b" :: Sym Integer) (ssym "c"), + testCase "IsString" $ do + ("a" :: Sym Bool) @=? Sym (ssymTerm "a"), + testGroup + "ToSym" + [ testCase "From self" $ do + toSym (ssym "a" :: Sym Bool) @=? (ssym "a" :: Sym Bool), + testCase "From concrete" $ do + toSym True @=? (con True :: Sym Bool) + ], + testGroup + "ToCon" + [ testCase "To self" $ do + toCon (ssym "a" :: Sym Bool) @=? (Nothing :: Maybe Bool), + testCase "To concrete" $ do + toCon True @=? Just True + ], + testCase "EvaluateSym" $ do + let m1 = emptyModel :: Model + let m2 = insertValue (SimpleSymbol "a") (1 :: Integer) m1 + let m3 = insertValue (SimpleSymbol "b") True m2 + evaluateSym False m3 (ites ("c" :: Sym Bool) "a" ("a" + "a" :: Sym Integer)) + @=? ites ("c" :: Sym Bool) 1 2 + evaluateSym True m3 (ites ("c" :: Sym Bool) "a" ("a" + "a" :: Sym Integer)) @=? 2, + testCase "ExtractSymbolics" $ do + extractSymbolics (ites ("c" :: Sym Bool) ("a" :: Sym Integer) ("b" :: Sym Integer)) + @=? SymbolSet + ( S.fromList + [ someTypedSymbol (SimpleSymbol "c" :: TypedSymbol Bool), + someTypedSymbol (SimpleSymbol "a" :: TypedSymbol Integer), + someTypedSymbol (SimpleSymbol "b" :: TypedSymbol Integer) + ] + ), + testCase "GenSym" $ do + (genSym () "a" :: UnionM (Sym Bool)) @=? mrgSingle (isym "a" 0) + (genSymSimple () "a" :: Sym Bool) @=? isym "a" 0 + (genSym (ssym "a" :: Sym Bool) "a" :: UnionM (Sym Bool)) @=? mrgSingle (isym "a" 0) + (genSymSimple (ssym "a" :: Sym Bool) "a" :: Sym Bool) @=? isym "a" 0 + (genSym () (nameWithInfo "a" True) :: UnionM (Sym Bool)) @=? mrgSingle (iinfosym "a" 0 True) + (genSymSimple () (nameWithInfo "a" True) :: Sym Bool) @=? iinfosym "a" 0 True, + testCase "SEq" $ do + (ssym "a" :: Sym Bool) ==~ ssym "b" @=? Sym (pevalEqvTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) + (ssym "a" :: Sym Bool) /=~ ssym "b" @=? Sym (pevalNotTerm $ pevalEqvTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) + ], + testGroup + "Sym Bool" + [ testGroup + "LogicalOp" + [ testCase "||~" $ do + ssym "a" ||~ ssym "b" @=? Sym (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), + testCase "&&~" $ do + ssym "a" &&~ ssym "b" @=? Sym (pevalAndTerm (ssymTerm "a") (ssymTerm "b")), + testCase "nots" $ do + nots (ssym "a") @=? Sym (pevalNotTerm (ssymTerm "a")), + testCase "xors" $ do + xors (ssym "a") (ssym "b") @=? Sym (pevalXorTerm (ssymTerm "a") (ssymTerm "b")), + testCase "implies" $ do + implies (ssym "a") (ssym "b") @=? Sym (pevalImplyTerm (ssymTerm "a") (ssymTerm "b")) + ] + ], + testGroup + "Sym Integer" + [ testGroup + "Num" + [ testCase "fromInteger" $ do + (1 :: Sym Integer) @=? Sym (conTerm 1), + testCase "(+)" $ do + (ssym "a" :: Sym Integer) + ssym "b" @=? Sym (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "(-)" $ do + (ssym "a" :: Sym Integer) - ssym "b" @=? Sym (pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "(*)" $ do + (ssym "a" :: Sym Integer) * ssym "b" @=? Sym (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "negate" $ do + negate (ssym "a" :: Sym Integer) @=? Sym (pevalUMinusNumTerm (ssymTerm "a")), + testCase "abs" $ do + abs (ssym "a" :: Sym Integer) @=? Sym (pevalAbsNumTerm (ssymTerm "a")), + testCase "signum" $ do + signum (ssym "a" :: Sym Integer) @=? Sym (pevalSignumNumTerm (ssymTerm "a")) + ], + testGroup + "SignedDivMod" + [ testProperty "divs on concrete" $ \(i :: Integer, j :: Integer) -> + ioProperty $ + divs (con i :: Sym Integer) (con j) + @=? if j == 0 + then merge $ throwError () :: ExceptT () UnionM SymInteger + else mrgSingle $ con $ i `div` j, + testCase "divs when divided by zero" $ do + divs (ssym "a" :: Sym Integer) (con 0) + @=? (merge $ throwError () :: ExceptT () UnionM SymInteger), + testCase "divs on symbolic" $ do + divs (ssym "a" :: Sym Integer) (ssym "b") + @=? ( mrgIf + ((ssym "b" :: Sym Integer) ==~ con (0 :: Integer) :: SymBool) + (throwError ()) + (mrgSingle $ Sym $ pevalDivIntegerTerm (ssymTerm "a") (ssymTerm "b")) :: + ExceptT () UnionM SymInteger + ), + testProperty "mods on concrete" $ \(i :: Integer, j :: Integer) -> + ioProperty $ + mods (con i :: Sym Integer) (con j) + @=? if j == 0 + then merge $ throwError () :: ExceptT () UnionM SymInteger + else mrgSingle $ con $ i `mod` j, + testCase "mods when divided by zero" $ do + mods (ssym "a" :: Sym Integer) (con 0) + @=? (merge $ throwError () :: ExceptT () UnionM SymInteger), + testCase "mods on symbolic" $ do + mods (ssym "a" :: Sym Integer) (ssym "b") + @=? ( mrgIf + ((ssym "b" :: Sym Integer) ==~ con (0 :: Integer) :: SymBool) + (throwError ()) + (mrgSingle $ Sym $ pevalModIntegerTerm (ssymTerm "a") (ssymTerm "b")) :: + ExceptT () UnionM SymInteger + ) + ], + testGroup + "SOrd" + [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do + (con i :: Sym Integer) <=~ con j @=? (con (i <= j) :: SymBool) + (con i :: Sym Integer) <~ con j @=? (con (i < j) :: SymBool) + (con i :: Sym Integer) >=~ con j @=? (con (i >= j) :: SymBool) + (con i :: Sym Integer) >~ con j @=? (con (i > j) :: SymBool) + (con i :: Sym Integer) + `symCompare` con j + @=? (i `symCompare` j :: UnionM Ordering), + testCase "SOrd on symbolic" $ do + let a :: Sym Integer = ssym "a" + let b :: Sym Integer = ssym "b" + let at :: Term Integer = ssymTerm "a" + let bt :: Term Integer = ssymTerm "b" + a <=~ b @=? Sym (pevalLeNumTerm at bt) + a <~ b @=? Sym (pevalLtNumTerm at bt) + a >=~ b @=? Sym (pevalGeNumTerm at bt) + a >~ b @=? Sym (pevalGtNumTerm at bt) + (a `symCompare` ssym "b" :: UnionM Ordering) + @=? mrgIf (a <~ b) (mrgSingle LT) (mrgIf (a ==~ b) (mrgSingle EQ) (mrgSingle GT)) + ] + ], + let au :: Sym (WordN 4) = ssym "a" + bu :: Sym (WordN 4) = ssym "b" + as :: Sym (IntN 4) = ssym "a" + bs :: Sym (IntN 4) = ssym "b" + aut :: Term (WordN 4) = ssymTerm "a" + but :: Term (WordN 4) = ssymTerm "b" + ast :: Term (IntN 4) = ssymTerm "a" + bst :: Term (IntN 4) = ssymTerm "b" + in testGroup + "Sym BV" + [ testGroup + "Num" + [ testCase "fromInteger" $ do + (1 :: Sym (WordN 4)) @=? Sym (conTerm 1) + (1 :: Sym (IntN 4)) @=? Sym (conTerm 1), + testCase "(+)" $ do + au + bu @=? Sym (pevalAddNumTerm aut but) + as + bs @=? Sym (pevalAddNumTerm ast bst), + testCase "(-)" $ do + au - bu @=? Sym (pevalMinusNumTerm aut but) + as - bs @=? Sym (pevalMinusNumTerm ast bst), + testCase "(*)" $ do + au * bu @=? Sym (pevalTimesNumTerm aut but) + as * bs @=? Sym (pevalTimesNumTerm ast bst), + testCase "negate" $ do + negate au @=? Sym (pevalUMinusNumTerm aut) + negate as @=? Sym (pevalUMinusNumTerm ast), + testCase "abs" $ do + abs au @=? Sym (pevalAbsNumTerm aut) + abs as @=? Sym (pevalAbsNumTerm ast), + testCase "signum" $ do + signum au @=? Sym (pevalSignumNumTerm aut) + signum as @=? Sym (pevalSignumNumTerm ast) + ], + testGroup + "SOrd" + [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do + let iu :: WordN 4 = fromInteger i + let ju :: WordN 4 = fromInteger j + let is :: IntN 4 = fromInteger i + let js :: IntN 4 = fromInteger j + let normalizeu k = k - k `div` 16 * 16 + let normalizes k = if normalizeu k >= 8 then normalizeu k - 16 else normalizeu k + (con iu :: Sym (WordN 4)) <=~ con ju @=? (con (normalizeu i <= normalizeu j) :: SymBool) + (con iu :: Sym (WordN 4)) <~ con ju @=? (con (normalizeu i < normalizeu j) :: SymBool) + (con iu :: Sym (WordN 4)) >=~ con ju @=? (con (normalizeu i >= normalizeu j) :: SymBool) + (con iu :: Sym (WordN 4)) >~ con ju @=? (con (normalizeu i > normalizeu j) :: SymBool) + (con iu :: Sym (WordN 4)) + `symCompare` con ju + @=? (normalizeu i `symCompare` normalizeu j :: UnionM Ordering) + (con is :: Sym (IntN 4)) <=~ con js @=? (con (normalizes i <= normalizes j) :: SymBool) + (con is :: Sym (IntN 4)) <~ con js @=? (con (normalizes i < normalizes j) :: SymBool) + (con is :: Sym (IntN 4)) >=~ con js @=? (con (normalizes i >= normalizes j) :: SymBool) + (con is :: Sym (IntN 4)) >~ con js @=? (con (normalizes i > normalizes j) :: SymBool) + (con is :: Sym (IntN 4)) + `symCompare` con js + @=? (normalizes i `symCompare` normalizes j :: UnionM Ordering), + testCase "SOrd on symbolic" $ do + au <=~ bu @=? Sym (pevalLeNumTerm aut but) + au <~ bu @=? Sym (pevalLtNumTerm aut but) + au >=~ bu @=? Sym (pevalGeNumTerm aut but) + au >~ bu @=? Sym (pevalGtNumTerm aut but) + (au `symCompare` bu :: UnionM Ordering) + @=? mrgIf (au <~ bu) (mrgSingle LT) (mrgIf (au ==~ bu) (mrgSingle EQ) (mrgSingle GT)) + + as <=~ bs @=? Sym (pevalLeNumTerm ast bst) + as <~ bs @=? Sym (pevalLtNumTerm ast bst) + as >=~ bs @=? Sym (pevalGeNumTerm ast bst) + as >~ bs @=? Sym (pevalGtNumTerm ast bst) + (as `symCompare` bs :: UnionM Ordering) + @=? mrgIf (as <~ bs) (mrgSingle LT) (mrgIf (as ==~ bs) (mrgSingle EQ) (mrgSingle GT)) + ], + testGroup + "Bits" + [ testCase ".&." $ do + au .&. bu @=? Sym (pevalAndBitsTerm aut but) + as .&. bs @=? Sym (pevalAndBitsTerm ast bst), + testCase ".|." $ do + au .|. bu @=? Sym (pevalOrBitsTerm aut but) + as .|. bs @=? Sym (pevalOrBitsTerm ast bst), + testCase "xor" $ do + au `xor` bu @=? Sym (pevalXorBitsTerm aut but) + as `xor` bs @=? Sym (pevalXorBitsTerm ast bst), + testCase "complement" $ do + complement au @=? Sym (pevalComplementBitsTerm aut) + complement as @=? Sym (pevalComplementBitsTerm ast), + testCase "shift" $ do + shift au 1 @=? Sym (pevalShiftBitsTerm aut 1) + shift as 1 @=? Sym (pevalShiftBitsTerm ast 1), + testCase "rotate" $ do + rotate au 1 @=? Sym (pevalRotateBitsTerm aut 1) + rotate as 1 @=? Sym (pevalRotateBitsTerm ast 1), + testCase "bitSize" $ do + bitSizeMaybe au @=? Just 4 + bitSizeMaybe as @=? Just 4, + testCase "isSigned" $ do + isSigned au @=? False + isSigned as @=? True, + testCase "testBit would only work on concrete ones" $ do + testBit (con 3 :: Sym (WordN 4)) 1 @=? True + testBit (con 3 :: Sym (WordN 4)) 2 @=? False + testBit (con 3 :: Sym (IntN 4)) 1 @=? True + testBit (con 3 :: Sym (IntN 4)) 2 @=? False, + testCase "bit would work" $ do + bit 1 @=? (con 2 :: Sym (WordN 4)) + bit 1 @=? (con 2 :: Sym (IntN 4)), + testCase "popCount would only work on concrete ones" $ do + popCount (con 3 :: Sym (WordN 4)) @=? 2 + popCount (con 3 :: Sym (WordN 4)) @=? 2 + popCount (con 3 :: Sym (IntN 4)) @=? 2 + popCount (con 3 :: Sym (IntN 4)) @=? 2 + ], + testGroup + "BVConcat" + [ testCase "bvconcat" $ do + bvconcat + (ssym "a" :: Sym (WordN 4)) + (ssym "b" :: Sym (WordN 3)) + @=? Sym + ( pevalBVConcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 3)) + ) + ], + testGroup + "bvextend for Sym BV" + [ testCase "bvzeroExtend" $ do + bvzeroExtend (Proxy @6) au @=? Sym (pevalBVExtendTerm False (Proxy @6) aut) + bvzeroExtend (Proxy @6) as @=? Sym (pevalBVExtendTerm False (Proxy @6) ast), + testCase "bvsignExtend" $ do + bvsignExtend (Proxy @6) au @=? Sym (pevalBVExtendTerm True (Proxy @6) aut) + bvsignExtend (Proxy @6) as @=? Sym (pevalBVExtendTerm True (Proxy @6) ast), + testCase "bvextend" $ do + bvextend (Proxy @6) au @=? Sym (pevalBVExtendTerm False (Proxy @6) aut) + bvextend (Proxy @6) as @=? Sym (pevalBVExtendTerm True (Proxy @6) ast) + ], + testGroup + "bvselect for Sym BV" + [ testCase "bvselect" $ do + bvselect (Proxy @2) (Proxy @1) au + @=? Sym (pevalBVSelectTerm (Proxy @2) (Proxy @1) aut) + bvselect (Proxy @2) (Proxy @1) as + @=? Sym (pevalBVSelectTerm (Proxy @2) (Proxy @1) ast) + ], + testGroup + "conversion between Int8 and Sym BV" + [ testCase "toSym" $ do + toSym (0 :: Int8) @=? (con 0 :: SymIntN 8) + toSym (-127 :: Int8) @=? (con $ -127 :: SymIntN 8) + toSym (-128 :: Int8) @=? (con $ -128 :: SymIntN 8) + toSym (127 :: Int8) @=? (con 127 :: SymIntN 8), + testCase "toCon" $ do + toCon (con 0 :: SymIntN 8) @=? Just (0 :: Int8) + toCon (con $ -127 :: SymIntN 8) @=? Just (-127 :: Int8) + toCon (con $ -128 :: SymIntN 8) @=? Just (-128 :: Int8) + toCon (con 127 :: SymIntN 8) @=? Just (127 :: Int8) + ], + testGroup + "conversion between Word8 and Sym BV" + [ testCase "toSym" $ do + toSym (0 :: Word8) @=? (con 0 :: SymWordN 8) + toSym (1 :: Word8) @=? (con 1 :: SymWordN 8) + toSym (255 :: Word8) @=? (con 255 :: SymWordN 8), + testCase "toCon" $ do + toCon (con 0 :: SymWordN 8) @=? Just (0 :: Word8) + toCon (con 1 :: SymWordN 8) @=? Just (1 :: Word8) + toCon (con 255 :: SymWordN 8) @=? Just (255 :: Word8) + ] + ], + testGroup + "TabularFun" + [ testCase "apply" $ do + (ssym "a" :: Integer =~> Integer) + # ssym "b" + @=? Sym (pevalTabularFunApplyTerm (ssymTerm "a" :: Term (Integer =-> Integer)) (ssymTerm "b")) + ], + testGroup + "Symbolic size" + [ testCase "symSize" $ do + symSize (ssym "a" :: Sym Integer) @=? 1 + symSize (con 1 :: Sym Integer) @=? 1 + symSize (con 1 + ssym "a" :: Sym Integer) @=? 3 + symSize (ssym "a" + ssym "a" :: Sym Integer) @=? 2 + symSize (-(ssym "a") :: Sym Integer) @=? 2 + symSize (ites (ssym "a" :: Sym Bool) (ssym "b") (ssym "c") :: Sym Integer) @=? 4, + testCase "symsSize" $ do + symsSize [ssym "a" :: Sym Integer, ssym "a" + ssym "a"] @=? 2 + ], + let asymbol :: TypedSymbol Integer = "a" + bsymbol :: TypedSymbol Bool = "b" + csymbol :: TypedSymbol Integer = "c" + dsymbol :: TypedSymbol Bool = "d" + esymbol :: TypedSymbol (WordN 4) = "e" + fsymbol :: TypedSymbol (IntN 4) = "f" + gsymbol :: TypedSymbol (WordN 16) = "g" + hsymbol :: TypedSymbol (IntN 16) = "h" + a :: Sym Integer = ssym "a" + b :: Sym Bool = "b" + c :: Sym Integer = "c" + d :: Sym Bool = "d" + e :: Sym (WordN 4) = "e" + f :: Sym (IntN 4) = "f" + g :: Sym (WordN 16) = "g" + h :: Sym (IntN 16) = "h" + in testCase + "construting Model from ModelSymPair" + $ do + buildModel (a := 1) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue (1 :: Integer))) + buildModel (a := 1, b := True) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True) + ] + ) + buildModel + ( a := 1, + b := True, + c := 2 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)) + ] + ) + buildModel + ( a := 1, + b := True, + c := 2, + d := False + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False) + ] + ) + buildModel + ( a := 1, + b := True, + c := 2, + d := False, + e := 3 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)) + ] + ) + buildModel + ( a := 1, + b := True, + c := 2, + d := False, + e := 3, + f := 4 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)) + ] + ) + buildModel + ( a := 1, + b := True, + c := 2, + d := False, + e := 3, + f := 4, + g := 5 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), + (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)) + ] + ) + buildModel + ( a := 1, + b := True, + c := 2, + d := False, + e := 3, + f := 4, + g := 5, + h := 6 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), + (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)), + (someTypedSymbol hsymbol, toModelValue (6 :: IntN 16)) + ] + ) + ] diff --git a/test/Grisette/IR/SymPrim/Data/TabularFunTests.hs b/test/Grisette/IR/SymPrim/Data/TabularFunTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/IR/SymPrim/Data/TabularFunTests.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.IR.SymPrim.Data.TabularFunTests where + +import Grisette.Core.Data.Class.Function +import Grisette.IR.SymPrim.Data.TabularFun +import Test.Tasty +import Test.Tasty.HUnit + +tabularFunTests :: TestTree +tabularFunTests = + testGroup + "TabularFunTests" + [ testCase "Tabular application" $ do + let f :: Integer =-> Integer = TabularFun [(1, 2), (3, 4)] 5 + (f # 0) @=? 5 + (f # 1) @=? 2 + (f # 2) @=? 5 + (f # 3) @=? 4 + (f # 4) @=? 5 + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,140 @@ +module Main where + +{- +import Grisette.Core.Control.ExceptionTests +import Grisette.Core.Control.Monad.UnionMBaseTests +import Grisette.Core.Data.Class.BoolTests +import Grisette.Core.Data.Class.EvaluateSymTests +import Grisette.Core.Data.Class.ExtractSymbolicsTests +import Grisette.Core.Data.Class.GenSymTests +import Grisette.Core.Data.Class.MergeableTests +import Grisette.Core.Data.Class.SEqTests +import Grisette.Core.Data.Class.SOrdTests +import Grisette.Core.Data.Class.SimpleMergeableTests +import Grisette.Core.Data.Class.ToConTests +import Grisette.Core.Data.Class.ToSymTests +import Grisette.Core.Data.Class.UnionLikeTests +import Grisette.Core.Data.UnionBaseTests +import Grisette.Lib.Control.Monad.ExceptTests +import Grisette.Lib.Control.Monad.TransTests +import Grisette.Lib.Control.MonadTests +import Grisette.Lib.Data.FoldableTests +import Grisette.Lib.Data.TraversableTests +-} + +import Grisette.Backend.SBV.Data.SMT.CEGISTests +import Grisette.Backend.SBV.Data.SMT.LoweringTests +import Grisette.Backend.SBV.Data.SMT.TermRewritingTests +import qualified Grisette.IR.SymPrim.Data.BVTests +import qualified Grisette.IR.SymPrim.Data.Prim.BVTests +import Grisette.IR.SymPrim.Data.Prim.BitsTests +import Grisette.IR.SymPrim.Data.Prim.BoolTests +import Grisette.IR.SymPrim.Data.Prim.IntegerTests +import Grisette.IR.SymPrim.Data.Prim.ModelTests +import Grisette.IR.SymPrim.Data.Prim.NumTests +import qualified Grisette.IR.SymPrim.Data.Prim.TabularFunTests +import Grisette.IR.SymPrim.Data.SymPrimTests +import qualified Grisette.IR.SymPrim.Data.TabularFunTests +import Test.Tasty +import Test.Tasty.Ingredients +import qualified Test.Tasty.Ingredients.ConsoleReporter as ConsoleReporter +import qualified Test.Tasty.Runners.Reporter as Reporter + +main :: IO () +main = defaultMainWithIngredients [composeReporters Reporter.ingredient ConsoleReporter.consoleTestReporter] tests + +tests :: TestTree +tests = + testGroup + "grisette" + [ irTests, + sbvTests + ] + +{- +coreTests :: TestTree +coreTests = + testGroup + "grisette-core" + [ testGroup + "Grisette" + [ testGroup + "Core" + [ testGroup + "Control" + [ testGroup + "Monad" + [ unionMBaseTests + ], + exceptionTests + ], + testGroup + "Data" + [ testGroup + "Class" + [ boolTests, + gevaluateSymTests, + gextractSymbolicsTests, + genSymTests, + mergeableTests, + seqTests, + simpleMergeableTests, + sordTests, + toConTests, + toSymTests, + unionLikeTests + ], + unionBaseTests + ] + ], + testGroup + "Lib" + [ testGroup + "Control" + [ testGroup + "Monad" + [ monadExceptFunctionTests, + monadTransFunctionTests + ], + monadFunctionTests + ], + testGroup + "Data" + [ foldableFunctionTests, + traversableFunctionTests + ] + ] + ] + ] +-} + +irTests :: TestTree +irTests = + testGroup + "grisette-symir" + [ testGroup + "Grisette.IR.SymPrim.Data" + [ testGroup + "Prim" + [ bitsTests, + boolTests, + Grisette.IR.SymPrim.Data.Prim.BVTests.bvTests, + integerTests, + modelTests, + numTests, + Grisette.IR.SymPrim.Data.Prim.TabularFunTests.tabularFunTests + ], + Grisette.IR.SymPrim.Data.BVTests.bvTests, + symPrimTests, + Grisette.IR.SymPrim.Data.TabularFunTests.tabularFunTests + ] + ] + +sbvTests :: TestTree +sbvTests = + testGroup + "Grisette.Backend.SBV.Data.SMT" + [ cegisTests, + loweringTests, + termRewritingTests + ]