diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 --- a/.circleci/config.yml +++ /dev/null @@ -1,53 +0,0 @@ ---- -version: 2.0 - -jobs: - build: - machine: - image: ubuntu-2004:202107-02 - steps: - - run: sudo apt-get update && sudo apt-get install -y curl git ssh unzip wget libtinfo-dev gcc make - - add_ssh_keys - - run: - name: Install z3 - command: | - wget https://github.com/Z3Prover/z3/releases/download/z3-4.8.7/z3-4.8.7-x64-ubuntu-16.04.zip - unzip z3-4.8.7-x64-ubuntu-16.04.zip - rm -f z3-4.8.7-x64-ubuntu-16.04.zip - sudo cp z3-4.8.7-x64-ubuntu-16.04/bin/libz3.a /usr/local/lib - sudo cp z3-4.8.7-x64-ubuntu-16.04/bin/z3 /usr/local/bin - sudo cp z3-4.8.7-x64-ubuntu-16.04/include/* /usr/local/include - rm -rf z3-4.8.7-x64-ubuntu-16.04 - z3 --version - - - checkout - - restore_cache: - keys: - - stack-cache-v1-{{ checksum "stack.yaml" }}-{{ checksum "liquid-fixpoint.cabal" }} - - stack-cache-v1-{{ checksum "stack.yaml" }} - - run: - name: Dependencies - command: | - wget -qO- https://get.haskellstack.org/ | sudo sh - stack --no-terminal setup - stack --no-terminal build -j2 liquid-fixpoint --only-dependencies --test --no-run-tests - - save_cache: - key: stack-cache-v1-{{ checksum "stack.yaml" }}-{{ checksum "liquid-fixpoint.cabal" }} - paths: - - ~/.stack - - ./.stack-work - - run: - name: Compile - command : | - stack --no-terminal build -j2 liquid-fixpoint --flag liquid-fixpoint:devel --test --no-run-tests - - run: - name: Test - command: | - mkdir -p /tmp/junit - stack --no-terminal test -j2 liquid-fixpoint:test --flag liquid-fixpoint:devel --test-arguments="--xml=/tmp/junit/main-test-results.xml": - stack --no-terminal haddock --flag liquid-fixpoint:devel --test --no-run-tests --no-haddock-deps --haddock-arguments="--no-print-missing-docs" - # mkdir -p $CIRCLE_TEST_REPORTS/tasty - # cp -r tests/logs/cur $CIRCLE_TEST_REPORTS/tasty/log - - run: - name: Dist - command: stack --no-terminal sdist diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc diff --git a/CHANGES.md b/CHANGES.md deleted file mode 100644 --- a/CHANGES.md +++ /dev/null @@ -1,47 +0,0 @@ -# CHANGES - -## NEXT - -- Fix bugs in PLE -- Move to GHC 8.6.4 -- Add `fuel` parameter to debug unfolding in PLE - -## 0.8.0.1 - -- Support for HORN-NNF format clauses, see `tests/horn/{pos,neg}/*.smt2` -- Support for "existential binders", see `tests/pos/ebind-*.fq` for example. - This only works with `--eliminate`. -- Move to GHC 8.4.3 - -## 0.7.0.0 - -- New `eliminate` based solver (see ICFP 2017 paper for algorithm) -- Proof by Logical Evaluation see `tests/proof` -- SMTLIB2 ADTs to make data constructors injective -- Uniformly support polymorphic functions via `apply` and elaborate - -## 0.3.0.0 - -- Make interpreted mul and div the default, when `solver = z3` -- Use `higherorder` flag to allow higher order binders into the environment - -## 0.2.2.0 - -- Added support for theory of Arrays `Map_t`, `Map_select`, `Map_store` - -- Added support for theory of Bitvectors -- see `Language.Fixpoint.Smt.Bitvector` - -- Added support for string literals - -## 0.2.1.0 - -- Pre-compiled binaries of the underlying ocaml solver are now - provided for Linux, Mac OSX, and Windows. - - No more need to install Ocaml! - -## 0.2.0.0 - -- Parsing has been improved to require *much* fewer parentheses. - -- Experimental support for Z3's theory of real numbers with the `--real` flag. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,366 +0,0 @@ -Liquid Fixpoint [![Hackage](https://img.shields.io/hackage/v/liquid-fixpoint.svg)](https://hackage.haskell.org/package/liquid-fixpoint) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/liquid-fixpoint.svg)](http://packdeps.haskellers.com/feed?needle=liquid-fixpoint) -[![CircleCI](https://circleci.com/gh/ucsd-progsys/liquid-fixpoint.svg?style=svg)](https://circleci.com/gh/ucsd-progsys/liquid-fixpoint) -=============== - - - - - -This package implements a Horn-Clause/Logical Implication constraint solver used -for various Liquid Types. The solver uses SMTLIB2 to implement an algorithm similar to: - -+ [Houdini](https://users.soe.ucsc.edu/~cormac/papers/fme01.pdf) -+ [Cartesian predicate abstraction](http://swt.informatik.uni-freiburg.de/berit/papers/boolean-and-cartesian-....pdf) - - -Requirements ------------- - -In addition to the .cabal dependencies you require an SMTLIB2 compatible solver binary: - -- [Z3](http://z3.codeplex.com) -- [CVC4](http://cvc4.cs.nyu.edu) -- [MathSat](http://mathsat.fbk.eu/download.html) - -If on Windows, please make sure to place the binary and any associated DLLs somewhere -in your path. - -How To Build and Install ------------------------- - - -Simply do: - -``` -$ git clone https://github.com/ucsd-progsys/liquid-fixpoint.git -$ cd liquid-fixpoint -$ stack install -``` - -or (`cabal` instead of `stack` if you prefer.) - - -Using SMTLIB-based SMT Solvers ------------------------------- - -You can use one of several SMTLIB2 compliant solvers, by: - - fixpoint --smtsolver=z3 path/to/file.hs - -Currently, we support - - * Z3 - * CVC4 - * MathSat - -"Horn" Format -------------- - -See the examples in `tests/horn/{pos, neg}` eg - -- [sum](tests/horn/pos/ple_sum.smt2) -- [list00](tests/horn/pos/ple_list00.smt2) -- [list03](tests/horn/pos/ple_list03.smt2) - -For how to write VCs "by hand". - -See [this tutorial](https://arxiv.org/abs/2010.07763) -with [accompanying code](https://github.com/ranjitjhala/sprite-lang) -for an example of how to generate Horn queries. - -The main datatypes are described in [src/Language/Fixpoint/Horn/Types.hs](src/Language/Fixpoint/Horn/Types.hs) - - -Configuration Management ------------------------- - -It is very important that the version of Liquid Fixpoint be maintained properly. - -Suppose that the current version of Liquid Haskell is `A.B.C.D`: - -+ After a release to hackage is made, if any of the components `B`, `C`, or `D` are missing, they shall be added and set to `0`. Then the `D` component of Liquid Fixpoint shall be incremented by `1`. The version of Liquid Fixpoint is now `A.B.C.(D + 1)` - -+ The first time a new function or type is exported from Liquid Fixpoint, if any of the components `B`, or `C` are missing, they shall be added and set to `0`. Then the `C` component shall be incremented by `1`, and the `D` component shall stripped. The version of Liquid Fixpoint is now `A.B.(C + 1)` - -+ The first time the signature of an exported function or type is changed, or an exported function or type is removed (this includes functions or types that Liquid Fixpoint re-exports from its own dependencies), if the `B` component is missing, it shall be added and set to `0`. Then the `B` component shall be incremented by `1`, and the `C` and `D` components shall be stripped. The version of Liquid Fixpoint is now `A.(B + 1)` - -+ The `A` component shall be updated at the sole discretion of the project owners. - -It is recommended to use the [Bumper](https://hackage.haskell.org/package/bumper) utility to manage the versioning of Liquid Fixpoint. Bumper will automatically do the correct update to the cabal file. Additionally, it will update any packages that you have the source for that depend on Liquid Fixpoint. - -To update Liquid Fixpoint and Liquid Haskell, first clone Liquid Haskell and Liquid Fixpoint to a common location: - -``` -git clone https://github.com/ucsd-progsys/liquidhaskell.git -git clone https://github.com/ucsd-progsys/liquid-fixpoint.git -``` - -To increment the `D` component of Liquid Fixpoint: - -``` -./path/to/bumper -3 liquid-fixpoint -``` - -This will update the `D` component of Liquid Fixpoint. If necessary, this will update the `Build-Depends` of Liquid Haskell. If the `Build-Depends` was updated, Liquid Haskell's `D` component will be incremented. - -To increment the `C` component of Liquid Fixpoint, and strip the `D` component: - -``` -./path/to/bumper --minor liquid-fixpoint -``` - -As before, this will update Liquid Fixpoint and, if necessary, Liquid Haskell. - -To increment the `B` component of Liquid Fixpoint, and strip the `D` and `C` components: - -``` -./path/to/bumper --major liquid-fixpoint -``` - -As before, this will update Liquid Fixpoint and, if necessary, Liquid Haskell - -## SMTLIB2 Interface - -There is a new SMTLIB2 interface directly from Haskell: - -+ Language.Fixpoint.SmtLib2 - -See `tests/smt2/{Smt.hs, foo.smt2}` for an example of how to use it. - -### Command Line for SMT2 interface - -You can use the `.smt2` interface from the command-line as follows: - -Use `--stdin` to read files from `stdin` - -``` -$ more tests/horn/pos/test01.smt | fixpoint --stdin - -Liquid-Fixpoint Copyright 2013-15 Regents of the University of California. -All Rights Reserved. - -Working 175% [==================================================================================================================] -Safe ( 3 constraints checked) -``` - -Use `-q` to disable all output (banner, progress bar etc.) - -``` -$ more tests/horn/pos/test01.smt | fixpoint -q --stdin -``` - -Use `--json` to get the output as a JSON object (rendered to `stdout`) - -``` -$ more tests/horn/pos/abs02-re.smt2 | stack exec -- fixpoint -q --json --stdin -"{\"result\":\"safe\"}" -``` - - -## Options - -`--higherorder` allows higher order binders into the environment - -`--extsolver` runs the **deprecated** external solver. - -`--parts` Partitions an `FInfo` into a `[FInfo]` and emits a bunch of files. So: - - $ fixpoint -n -p path/to/foo.fq - -will now emit files: - - path/to/.liquid/foo.1.fq - path/to/.liquid/foo.2.fq - . . . - path/to/.liquid/foo.k.fq - -and also a dot file with the constraint dependency graph: - - path/to/.liquid/foo.fq.dot - - -## FInfo Invariants - -### Binders - -This is the field - -``` - , bs :: !BindEnv -- ^ Bind |-> (Symbol, SortedReft) -``` - -or in the .fq files as - -``` -bind 1 x : ... -bind 2 y : ... -``` - -* Each `BindId` must be a distinct `Int`, -* Each `BindId` that appears in a constraint - environment i.e. inside _any_ `IBindEnv` - must appear inside the `bs` - -### Environments - -* Each constraint's environment is a set of `BindId` - which must be defined in the `bindInfo`. Furthermore - -* Each constraint should not have _duplicate_ names in its - environment, that is if you have two binders - -``` - bind 1 x : ... - bind 12 x : ... -``` - - Then a single `IBindEnv` should only mention _at most_ - one of `1` or `12`. - -* There is also a "tree-shape" property that its a bit hard - to describe ... TODO - -### LHS - -Each `slhs` of a constraint is a `SortedReft`. - -- Each `SortredReft` is basically a `Reft` -- a logical predicate. - The important bit is that a `KVar` i.e. terms of the formalized - -``` - $k1[x1:=y1][x2:=y2]...[xn:=yn] -``` - - That is represented in the `Expr` type as - -``` - | PKVar !KVar !Subst -``` - - must appear _only_ at the **top-level** that is not under _any_ - other operators, i.e. not as a sub-`Expr` of other expressions. - - -- This is basically a predicate that needs to be "well sorted" - with respect to the `BindId`, intuitively - -``` - x:int, y:int |- x + y : int -``` - - is well sorted. but - -``` - x:int |- x + y : int -``` - - is not, and - -``` - x:int, y: list |- x + y : int -``` - - is not. The exact definition is formalized in `Language.Fixpoint.SortCheck` - - -### RHS - -Similarly each `rhs` of a `SubC` must either be a single `$k[...]` or an plain `$k`-free `Expr`. - -### Global vs. Distinct Literals - -``` - , gLits :: !(SEnv Sort) -- ^ Global Constant symbols - , dLits :: !(SEnv Sort) -``` - -The _global_ literals `gLits` are symbols that -are in scope _everywhere_ i.e. need not be separately -defined in individual environments. These include things like - -- uninterpreted _measure_ functions `len`, `height`, -- uninterpreted _data constructor_ literals `True`, `False` - -Suppose you have an enumerated type like: - -``` -data Day = Sun | Mon | Tue | Wed | ... | Sat -``` - -You can model the above values in fixpoint as: - -``` -constant lit#Sun : Day -constant lit#Mon : Day -constant lit#Tue : Day -constant lit#Wed : Day -``` - -The _distinct_ literals are a subset of the above where we -want to tell the SMT solver that the values are *distinct* -i.e. **not equal** to each other, for example, you can -**additionally** specify this as: - -``` -distinct lit#Sun : Day -distinct lit#Mon : Day -distinct lit#Tue : Day -distinct lit#Wed : Day -``` - -The above two are represented programmatically by generating -suitable `Symbol` values (for the literals see `litSymbol`) -and `Sort` values as `FTC FTycon` and then making an `SEnv` -from the `[(Symbol, Sort)]`. - -### Sorts - -> What's the difference between an FTC and an FObj? - -In early versions of fixpoint, there was support for -three sorts for expressions (`Expr`) that were sent -to the SMT solver: - -1. `int` -2. `bool` -3. "other" - -The `FObj` sort was introduced to represent essentially _all_ -non-int and non-bool values (e.g. tuples, lists, trees, pointers...) - -However, we later realized that it is valuable to keep _more_ -precise information for `Expr`s and so we introduced the `FTC` -(fixpoint type constructor), which lets us represent the above -respectively as: - -- `FTC "String" []` -- in Haskell `String` -- `FTC "Tuple" [FInt, Bool]` -- in Haskell `(Int, Bool)` -- `FTC "List" [FTC "List" [FInt]]` -- in Haskell `[[Int]]` - -> There is a comment that says FObj's are uninterpretted types; -> so probably a type the SMT solver doesn't know about? -> Does that then make FTC types that the SMT solver does -> know about (bools, ints, lists, sets, etc.)? - -The SMT solver knows about `bool`, `int` and `set` (also `bitvector` -and `map`) but _all_ other types are _currently_ represented as plain -`Int` inside the SMT solver. However, we _will be_ changing this -to make use of SMT support for ADTs ... - -To sum up: the `FObj` is there for historical reasons; it has been -subsumed by `FTC` which is what I recomend you use. However `FObj` -is there if you want a simple "unitype" / "any" type for terms -that are not "interpreted". - -## Qualifier Patterns - -```haskell -λ> doParse' (qualParamP sortP) "" "z as (mon . $1) : int" -QP {qpSym = "z", qpPat = PatPrefix "mon" 1, qpSort = FInt} -λ> doParse' (qualParamP sortP) "" "z as ($1 . mon) : int" -QP {qpSym = "z", qpPat = PatSuffix 1 "mon", qpSort = FInt} -λ> doParse' (qualParamP sortP) "" "z as mon : int" -QP {qpSym = "z", qpPat = PatExact "mon", qpSort = FInt} -λ> doParse' (qualParamP sortP) "" "z : int" -QP {qpSym = "z", qpPat = PatNone, qpSort = FInt} -``` diff --git a/TODO.md b/TODO.md deleted file mode 100644 --- a/TODO.md +++ /dev/null @@ -1,2 +0,0 @@ -# TODO - diff --git a/bin/Fixpoint.hs b/bin/Fixpoint.hs --- a/bin/Fixpoint.hs +++ b/bin/Fixpoint.hs @@ -1,12 +1,12 @@ import Language.Fixpoint.Solver (solveFQ) import Language.Fixpoint.Horn.Solve (solveHorn) -import qualified Language.Fixpoint.Misc as Misc -import qualified Language.Fixpoint.Types as F -import qualified Language.Fixpoint.Types.Config as F -import qualified Language.Fixpoint.Utils.Files as F +import qualified Language.Fixpoint.Misc as Misc +import qualified Language.Fixpoint.Types as F +import qualified Language.Fixpoint.Types.Config as F +import qualified Language.Fixpoint.Utils.Files as F import System.Exit -import qualified Control.Exception as Ex +import qualified Control.Exception as Ex main :: IO () main = do @@ -18,13 +18,13 @@ --------------------------------------------------------------------------- solveQuery :: F.Config -> IO ExitCode solveQuery cfg = solver cfg `Ex.catch` errorExit - where - solver - | isHorn cfg = solveHorn - | otherwise = solveFQ + where + solver + | isHorn cfg = solveHorn + | otherwise = solveFQ -isHorn :: F.Config -> Bool -isHorn cfg = F.isExtFile F.Smt2 (F.srcFile cfg) || F.stdin cfg +isHorn :: F.Config -> Bool +isHorn cfg = F.isExtFile F.Smt2 (F.srcFile cfg) || F.stdin cfg errorExit :: F.Error -> IO ExitCode errorExit e = do diff --git a/default.nix b/default.nix deleted file mode 100644 --- a/default.nix +++ /dev/null @@ -1,52 +0,0 @@ -{ makeEnv ? false, config ? { allowBroken = true; }, ... }: -let - # fetch pinned version of nixpkgs - nixpkgs = import ( - builtins.fetchTarball { - # fetch latest nixpkgs https://github.com/NixOS/nixpkgs-channels/tree/nixos-20.03 as of Tue 18 Aug 2020 02:51:27 PM UTC - url = "https://github.com/NixOS/nixpkgs-channels/archive/cb1996818edf506c0d1665ab147c253c558a7426.tar.gz"; - sha256 = "0lb6idvg2aj61nblr41x0ixwbphih2iz8xxc05m69hgsn261hk3j"; - } - ) { inherit config; }; - # override haskell compiler version, add and override dependencies in nixpkgs - haskellPackages = nixpkgs.haskell.packages."ghc8101".override ( - old: { - all-cabal-hashes = nixpkgs.fetchurl { - # fetch latest cabal hashes https://github.com/commercialhaskell/all-cabal-hashes/tree/hackage as of Tue 18 Aug 2020 02:51:27 PM UTC - url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/112fef7b4bf392d4d4c36fbbe00ed061685ba26c.tar.gz"; - sha256 = "0x0mkpwnndw7n62l089gimd76n9gy749giban9pacf5kxbsfxrdc"; - }; - overrides = self: super: with nixpkgs.haskell.lib; rec { - mkDerivation = args: super.mkDerivation ( - args // { - doCheck = false; - doHaddock = false; - jailbreak = true; - } - ); - # test dependencies - git = overrideCabal (self.callHackage "git" "0.3.0" {}) ( - old: { - patches = [ ./git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch ]; # git-0.3.0 defines a Monad a fail function, which is incompatible with ghc-8.10.1 https://hackage.haskell.org/package/git-0.3.0/docs/src/Data.Git.Monad.html#line-240 - } - ); - # build dependencies; using latest hackage releases as of Tue 18 Aug 2020 02:51:27 PM UTC - memory = self.callHackage "memory" "0.15.0" {}; - }; - } - ); - # function to bring devtools in to a package environment - devtools = old: { nativeBuildInputs = old.nativeBuildInputs ++ [ nixpkgs.cabal-install nixpkgs.ghcid ]; }; # ghc and hpack are automatically included - # ignore files specified by gitignore in nix-build - source = nixpkgs.nix-gitignore.gitignoreSource [] ./.; - # use overridden-haskellPackages to call gitignored-source - drv = nixpkgs.haskell.lib.overrideCabal (haskellPackages.callCabal2nix "liquid-fixpoint" source {}) ( - old: { - buildTools = [ nixpkgs.z3 ]; - doCheck = true; - doHaddock = true; - preCheck = ''export PATH="$PWD/dist/build/fixpoint:$PATH"''; # bring the `fixpoint` binary into scope for tests run by nix-build - } - ); -in -if makeEnv then drv.env.overrideAttrs devtools else drv diff --git a/dist/build/Data/ShareMap.dyn_hi b/dist/build/Data/ShareMap.dyn_hi deleted file mode 100644 Binary files a/dist/build/Data/ShareMap.dyn_hi and /dev/null differ diff --git a/dist/build/Data/ShareMap.dyn_o b/dist/build/Data/ShareMap.dyn_o deleted file mode 100644 Binary files a/dist/build/Data/ShareMap.dyn_o and /dev/null differ diff --git a/dist/build/Data/ShareMap.hi b/dist/build/Data/ShareMap.hi deleted file mode 100644 Binary files a/dist/build/Data/ShareMap.hi and /dev/null differ diff --git a/dist/build/Data/ShareMap.o b/dist/build/Data/ShareMap.o deleted file mode 100644 Binary files a/dist/build/Data/ShareMap.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Defunctionalize.dyn_hi b/dist/build/Language/Fixpoint/Defunctionalize.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Defunctionalize.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Defunctionalize.dyn_o b/dist/build/Language/Fixpoint/Defunctionalize.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Defunctionalize.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Defunctionalize.hi b/dist/build/Language/Fixpoint/Defunctionalize.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Defunctionalize.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Defunctionalize.o b/dist/build/Language/Fixpoint/Defunctionalize.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Defunctionalize.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph.dyn_hi b/dist/build/Language/Fixpoint/Graph.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph.dyn_o b/dist/build/Language/Fixpoint/Graph.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph.hi b/dist/build/Language/Fixpoint/Graph.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph.o b/dist/build/Language/Fixpoint/Graph.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Deps.dyn_hi b/dist/build/Language/Fixpoint/Graph/Deps.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Deps.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Deps.dyn_o b/dist/build/Language/Fixpoint/Graph/Deps.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Deps.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Deps.hi b/dist/build/Language/Fixpoint/Graph/Deps.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Deps.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Deps.o b/dist/build/Language/Fixpoint/Graph/Deps.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Deps.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Indexed.dyn_hi b/dist/build/Language/Fixpoint/Graph/Indexed.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Indexed.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Indexed.dyn_o b/dist/build/Language/Fixpoint/Graph/Indexed.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Indexed.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Indexed.hi b/dist/build/Language/Fixpoint/Graph/Indexed.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Indexed.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Indexed.o b/dist/build/Language/Fixpoint/Graph/Indexed.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Indexed.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Partition.dyn_hi b/dist/build/Language/Fixpoint/Graph/Partition.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Partition.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Partition.dyn_o b/dist/build/Language/Fixpoint/Graph/Partition.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Partition.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Partition.hi b/dist/build/Language/Fixpoint/Graph/Partition.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Partition.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Partition.o b/dist/build/Language/Fixpoint/Graph/Partition.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Partition.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Reducible.dyn_hi b/dist/build/Language/Fixpoint/Graph/Reducible.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Reducible.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Reducible.dyn_o b/dist/build/Language/Fixpoint/Graph/Reducible.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Reducible.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Reducible.hi b/dist/build/Language/Fixpoint/Graph/Reducible.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Reducible.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Reducible.o b/dist/build/Language/Fixpoint/Graph/Reducible.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Reducible.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Types.dyn_hi b/dist/build/Language/Fixpoint/Graph/Types.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Types.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Types.dyn_o b/dist/build/Language/Fixpoint/Graph/Types.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Types.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Types.hi b/dist/build/Language/Fixpoint/Graph/Types.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Types.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Graph/Types.o b/dist/build/Language/Fixpoint/Graph/Types.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Graph/Types.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Info.dyn_hi b/dist/build/Language/Fixpoint/Horn/Info.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Info.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Info.dyn_o b/dist/build/Language/Fixpoint/Horn/Info.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Info.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Info.hi b/dist/build/Language/Fixpoint/Horn/Info.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Info.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Info.o b/dist/build/Language/Fixpoint/Horn/Info.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Info.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Parse.dyn_hi b/dist/build/Language/Fixpoint/Horn/Parse.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Parse.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Parse.dyn_o b/dist/build/Language/Fixpoint/Horn/Parse.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Parse.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Parse.hi b/dist/build/Language/Fixpoint/Horn/Parse.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Parse.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Parse.o b/dist/build/Language/Fixpoint/Horn/Parse.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Parse.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Solve.dyn_hi b/dist/build/Language/Fixpoint/Horn/Solve.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Solve.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Solve.dyn_o b/dist/build/Language/Fixpoint/Horn/Solve.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Solve.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Solve.hi b/dist/build/Language/Fixpoint/Horn/Solve.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Solve.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Solve.o b/dist/build/Language/Fixpoint/Horn/Solve.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Solve.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Transformations.dyn_hi b/dist/build/Language/Fixpoint/Horn/Transformations.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Transformations.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Transformations.dyn_o b/dist/build/Language/Fixpoint/Horn/Transformations.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Transformations.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Transformations.hi b/dist/build/Language/Fixpoint/Horn/Transformations.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Transformations.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Transformations.o b/dist/build/Language/Fixpoint/Horn/Transformations.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Transformations.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Types.dyn_hi b/dist/build/Language/Fixpoint/Horn/Types.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Types.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Types.dyn_o b/dist/build/Language/Fixpoint/Horn/Types.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Types.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Types.hi b/dist/build/Language/Fixpoint/Horn/Types.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Types.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Horn/Types.o b/dist/build/Language/Fixpoint/Horn/Types.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Horn/Types.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Minimize.dyn_hi b/dist/build/Language/Fixpoint/Minimize.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Minimize.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Minimize.dyn_o b/dist/build/Language/Fixpoint/Minimize.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Minimize.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Minimize.hi b/dist/build/Language/Fixpoint/Minimize.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Minimize.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Minimize.o b/dist/build/Language/Fixpoint/Minimize.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Minimize.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Misc.dyn_hi b/dist/build/Language/Fixpoint/Misc.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Misc.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Misc.dyn_o b/dist/build/Language/Fixpoint/Misc.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Misc.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Misc.hi b/dist/build/Language/Fixpoint/Misc.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Misc.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Misc.o b/dist/build/Language/Fixpoint/Misc.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Misc.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Parse.dyn_hi b/dist/build/Language/Fixpoint/Parse.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Parse.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Parse.dyn_o b/dist/build/Language/Fixpoint/Parse.dyn_o deleted file mode 100644 # file too large to diff: dist/build/Language/Fixpoint/Parse.dyn_o diff --git a/dist/build/Language/Fixpoint/Parse.hi b/dist/build/Language/Fixpoint/Parse.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Parse.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Parse.o b/dist/build/Language/Fixpoint/Parse.o deleted file mode 100644 # file too large to diff: dist/build/Language/Fixpoint/Parse.o diff --git a/dist/build/Language/Fixpoint/Smt/Bitvector.dyn_hi b/dist/build/Language/Fixpoint/Smt/Bitvector.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Bitvector.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Bitvector.dyn_o b/dist/build/Language/Fixpoint/Smt/Bitvector.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Bitvector.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Bitvector.hi b/dist/build/Language/Fixpoint/Smt/Bitvector.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Bitvector.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Bitvector.o b/dist/build/Language/Fixpoint/Smt/Bitvector.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Bitvector.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Interface.dyn_hi b/dist/build/Language/Fixpoint/Smt/Interface.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Interface.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Interface.dyn_o b/dist/build/Language/Fixpoint/Smt/Interface.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Interface.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Interface.hi b/dist/build/Language/Fixpoint/Smt/Interface.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Interface.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Interface.o b/dist/build/Language/Fixpoint/Smt/Interface.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Interface.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Serialize.dyn_hi b/dist/build/Language/Fixpoint/Smt/Serialize.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Serialize.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Serialize.dyn_o b/dist/build/Language/Fixpoint/Smt/Serialize.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Serialize.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Serialize.hi b/dist/build/Language/Fixpoint/Smt/Serialize.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Serialize.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Serialize.o b/dist/build/Language/Fixpoint/Smt/Serialize.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Serialize.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Theories.dyn_hi b/dist/build/Language/Fixpoint/Smt/Theories.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Theories.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Theories.dyn_o b/dist/build/Language/Fixpoint/Smt/Theories.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Theories.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Theories.hi b/dist/build/Language/Fixpoint/Smt/Theories.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Theories.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Theories.o b/dist/build/Language/Fixpoint/Smt/Theories.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Theories.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Types.dyn_hi b/dist/build/Language/Fixpoint/Smt/Types.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Types.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Types.dyn_o b/dist/build/Language/Fixpoint/Smt/Types.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Types.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Types.hi b/dist/build/Language/Fixpoint/Smt/Types.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Types.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Smt/Types.o b/dist/build/Language/Fixpoint/Smt/Types.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Smt/Types.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver.dyn_hi b/dist/build/Language/Fixpoint/Solver.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver.dyn_o b/dist/build/Language/Fixpoint/Solver.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver.hi b/dist/build/Language/Fixpoint/Solver.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver.o b/dist/build/Language/Fixpoint/Solver.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Eliminate.dyn_hi b/dist/build/Language/Fixpoint/Solver/Eliminate.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Eliminate.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Eliminate.dyn_o b/dist/build/Language/Fixpoint/Solver/Eliminate.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Eliminate.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Eliminate.hi b/dist/build/Language/Fixpoint/Solver/Eliminate.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Eliminate.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Eliminate.o b/dist/build/Language/Fixpoint/Solver/Eliminate.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Eliminate.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_hi b/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_o b/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.hi b/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.o b/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/EnvironmentReduction.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Extensionality.dyn_hi b/dist/build/Language/Fixpoint/Solver/Extensionality.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Extensionality.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Extensionality.dyn_o b/dist/build/Language/Fixpoint/Solver/Extensionality.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Extensionality.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Extensionality.hi b/dist/build/Language/Fixpoint/Solver/Extensionality.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Extensionality.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Extensionality.o b/dist/build/Language/Fixpoint/Solver/Extensionality.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Extensionality.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_hi b/dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_o b/dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/GradualSolution.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/GradualSolution.hi b/dist/build/Language/Fixpoint/Solver/GradualSolution.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/GradualSolution.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/GradualSolution.o b/dist/build/Language/Fixpoint/Solver/GradualSolution.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/GradualSolution.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Instantiate.dyn_hi b/dist/build/Language/Fixpoint/Solver/Instantiate.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Instantiate.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Instantiate.dyn_o b/dist/build/Language/Fixpoint/Solver/Instantiate.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Instantiate.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Instantiate.hi b/dist/build/Language/Fixpoint/Solver/Instantiate.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Instantiate.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Instantiate.o b/dist/build/Language/Fixpoint/Solver/Instantiate.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Instantiate.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Monad.dyn_hi b/dist/build/Language/Fixpoint/Solver/Monad.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Monad.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Monad.dyn_o b/dist/build/Language/Fixpoint/Solver/Monad.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Monad.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Monad.hi b/dist/build/Language/Fixpoint/Solver/Monad.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Monad.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Monad.o b/dist/build/Language/Fixpoint/Solver/Monad.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Monad.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/PLE.dyn_hi b/dist/build/Language/Fixpoint/Solver/PLE.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/PLE.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/PLE.dyn_o b/dist/build/Language/Fixpoint/Solver/PLE.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/PLE.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/PLE.hi b/dist/build/Language/Fixpoint/Solver/PLE.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/PLE.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/PLE.o b/dist/build/Language/Fixpoint/Solver/PLE.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/PLE.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Prettify.dyn_hi b/dist/build/Language/Fixpoint/Solver/Prettify.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Prettify.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Prettify.dyn_o b/dist/build/Language/Fixpoint/Solver/Prettify.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Prettify.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Prettify.hi b/dist/build/Language/Fixpoint/Solver/Prettify.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Prettify.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Prettify.o b/dist/build/Language/Fixpoint/Solver/Prettify.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Prettify.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Rewrite.dyn_hi b/dist/build/Language/Fixpoint/Solver/Rewrite.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Rewrite.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Rewrite.dyn_o b/dist/build/Language/Fixpoint/Solver/Rewrite.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Rewrite.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Rewrite.hi b/dist/build/Language/Fixpoint/Solver/Rewrite.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Rewrite.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Rewrite.o b/dist/build/Language/Fixpoint/Solver/Rewrite.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Rewrite.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Sanitize.dyn_hi b/dist/build/Language/Fixpoint/Solver/Sanitize.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Sanitize.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Sanitize.dyn_o b/dist/build/Language/Fixpoint/Solver/Sanitize.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Sanitize.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Sanitize.hi b/dist/build/Language/Fixpoint/Solver/Sanitize.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Sanitize.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Sanitize.o b/dist/build/Language/Fixpoint/Solver/Sanitize.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Sanitize.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solution.dyn_hi b/dist/build/Language/Fixpoint/Solver/Solution.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solution.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solution.dyn_o b/dist/build/Language/Fixpoint/Solver/Solution.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solution.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solution.hi b/dist/build/Language/Fixpoint/Solver/Solution.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solution.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solution.o b/dist/build/Language/Fixpoint/Solver/Solution.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solution.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solve.dyn_hi b/dist/build/Language/Fixpoint/Solver/Solve.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solve.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solve.dyn_o b/dist/build/Language/Fixpoint/Solver/Solve.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solve.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solve.hi b/dist/build/Language/Fixpoint/Solver/Solve.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solve.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Solve.o b/dist/build/Language/Fixpoint/Solver/Solve.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Solve.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Stats.dyn_hi b/dist/build/Language/Fixpoint/Solver/Stats.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Stats.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Stats.dyn_o b/dist/build/Language/Fixpoint/Solver/Stats.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Stats.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Stats.hi b/dist/build/Language/Fixpoint/Solver/Stats.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Stats.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Stats.o b/dist/build/Language/Fixpoint/Solver/Stats.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Stats.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_hi b/dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_o b/dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/TrivialSort.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/TrivialSort.hi b/dist/build/Language/Fixpoint/Solver/TrivialSort.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/TrivialSort.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/TrivialSort.o b/dist/build/Language/Fixpoint/Solver/TrivialSort.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/TrivialSort.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_hi b/dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_o b/dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.hi b/dist/build/Language/Fixpoint/Solver/UniqifyBinds.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.o b/dist/build/Language/Fixpoint/Solver/UniqifyBinds.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyBinds.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_hi b/dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_o b/dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.hi b/dist/build/Language/Fixpoint/Solver/UniqifyKVars.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.o b/dist/build/Language/Fixpoint/Solver/UniqifyKVars.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/UniqifyKVars.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Worklist.dyn_hi b/dist/build/Language/Fixpoint/Solver/Worklist.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Worklist.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Worklist.dyn_o b/dist/build/Language/Fixpoint/Solver/Worklist.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Worklist.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Worklist.hi b/dist/build/Language/Fixpoint/Solver/Worklist.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Worklist.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Solver/Worklist.o b/dist/build/Language/Fixpoint/Solver/Worklist.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Solver/Worklist.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/SortCheck.dyn_hi b/dist/build/Language/Fixpoint/SortCheck.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/SortCheck.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/SortCheck.dyn_o b/dist/build/Language/Fixpoint/SortCheck.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/SortCheck.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/SortCheck.hi b/dist/build/Language/Fixpoint/SortCheck.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/SortCheck.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/SortCheck.o b/dist/build/Language/Fixpoint/SortCheck.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/SortCheck.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types.dyn_hi b/dist/build/Language/Fixpoint/Types.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types.dyn_o b/dist/build/Language/Fixpoint/Types.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types.hi b/dist/build/Language/Fixpoint/Types.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types.o b/dist/build/Language/Fixpoint/Types.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Config.dyn_hi b/dist/build/Language/Fixpoint/Types/Config.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Config.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Config.dyn_o b/dist/build/Language/Fixpoint/Types/Config.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Config.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Config.hi b/dist/build/Language/Fixpoint/Types/Config.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Config.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Config.o b/dist/build/Language/Fixpoint/Types/Config.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Config.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Constraints.dyn_hi b/dist/build/Language/Fixpoint/Types/Constraints.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Constraints.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Constraints.dyn_o b/dist/build/Language/Fixpoint/Types/Constraints.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Constraints.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Constraints.hi b/dist/build/Language/Fixpoint/Types/Constraints.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Constraints.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Constraints.o b/dist/build/Language/Fixpoint/Types/Constraints.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Constraints.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Environments.dyn_hi b/dist/build/Language/Fixpoint/Types/Environments.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Environments.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Environments.dyn_o b/dist/build/Language/Fixpoint/Types/Environments.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Environments.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Environments.hi b/dist/build/Language/Fixpoint/Types/Environments.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Environments.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Environments.o b/dist/build/Language/Fixpoint/Types/Environments.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Environments.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Errors.dyn_hi b/dist/build/Language/Fixpoint/Types/Errors.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Errors.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Errors.dyn_o b/dist/build/Language/Fixpoint/Types/Errors.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Errors.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Errors.hi b/dist/build/Language/Fixpoint/Types/Errors.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Errors.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Errors.o b/dist/build/Language/Fixpoint/Types/Errors.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Errors.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Graduals.dyn_hi b/dist/build/Language/Fixpoint/Types/Graduals.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Graduals.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Graduals.dyn_o b/dist/build/Language/Fixpoint/Types/Graduals.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Graduals.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Graduals.hi b/dist/build/Language/Fixpoint/Types/Graduals.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Graduals.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Graduals.o b/dist/build/Language/Fixpoint/Types/Graduals.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Graduals.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Names.dyn_hi b/dist/build/Language/Fixpoint/Types/Names.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Names.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Names.dyn_o b/dist/build/Language/Fixpoint/Types/Names.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Names.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Names.hi b/dist/build/Language/Fixpoint/Types/Names.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Names.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Names.o b/dist/build/Language/Fixpoint/Types/Names.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Names.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_hi b/dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_o b/dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/PrettyPrint.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/PrettyPrint.hi b/dist/build/Language/Fixpoint/Types/PrettyPrint.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/PrettyPrint.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/PrettyPrint.o b/dist/build/Language/Fixpoint/Types/PrettyPrint.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/PrettyPrint.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Refinements.dyn_hi b/dist/build/Language/Fixpoint/Types/Refinements.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Refinements.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Refinements.dyn_o b/dist/build/Language/Fixpoint/Types/Refinements.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Refinements.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Refinements.hi b/dist/build/Language/Fixpoint/Types/Refinements.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Refinements.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Refinements.o b/dist/build/Language/Fixpoint/Types/Refinements.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Refinements.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Solutions.dyn_hi b/dist/build/Language/Fixpoint/Types/Solutions.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Solutions.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Solutions.dyn_o b/dist/build/Language/Fixpoint/Types/Solutions.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Solutions.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Solutions.hi b/dist/build/Language/Fixpoint/Types/Solutions.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Solutions.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Solutions.o b/dist/build/Language/Fixpoint/Types/Solutions.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Solutions.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Sorts.dyn_hi b/dist/build/Language/Fixpoint/Types/Sorts.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Sorts.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Sorts.dyn_o b/dist/build/Language/Fixpoint/Types/Sorts.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Sorts.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Sorts.hi b/dist/build/Language/Fixpoint/Types/Sorts.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Sorts.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Sorts.o b/dist/build/Language/Fixpoint/Types/Sorts.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Sorts.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Spans.dyn_hi b/dist/build/Language/Fixpoint/Types/Spans.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Spans.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Spans.dyn_o b/dist/build/Language/Fixpoint/Types/Spans.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Spans.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Spans.hi b/dist/build/Language/Fixpoint/Types/Spans.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Spans.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Spans.o b/dist/build/Language/Fixpoint/Types/Spans.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Spans.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Substitutions.dyn_hi b/dist/build/Language/Fixpoint/Types/Substitutions.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Substitutions.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Substitutions.dyn_o b/dist/build/Language/Fixpoint/Types/Substitutions.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Substitutions.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Substitutions.hi b/dist/build/Language/Fixpoint/Types/Substitutions.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Substitutions.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Substitutions.o b/dist/build/Language/Fixpoint/Types/Substitutions.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Substitutions.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Templates.dyn_hi b/dist/build/Language/Fixpoint/Types/Templates.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Templates.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Templates.dyn_o b/dist/build/Language/Fixpoint/Types/Templates.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Templates.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Templates.hi b/dist/build/Language/Fixpoint/Types/Templates.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Templates.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Templates.o b/dist/build/Language/Fixpoint/Types/Templates.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Templates.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Theories.dyn_hi b/dist/build/Language/Fixpoint/Types/Theories.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Theories.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Theories.dyn_o b/dist/build/Language/Fixpoint/Types/Theories.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Theories.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Theories.hi b/dist/build/Language/Fixpoint/Types/Theories.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Theories.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Theories.o b/dist/build/Language/Fixpoint/Types/Theories.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Theories.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Triggers.dyn_hi b/dist/build/Language/Fixpoint/Types/Triggers.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Triggers.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Triggers.dyn_o b/dist/build/Language/Fixpoint/Types/Triggers.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Triggers.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Triggers.hi b/dist/build/Language/Fixpoint/Types/Triggers.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Triggers.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Triggers.o b/dist/build/Language/Fixpoint/Types/Triggers.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Triggers.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Utils.dyn_hi b/dist/build/Language/Fixpoint/Types/Utils.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Utils.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Utils.dyn_o b/dist/build/Language/Fixpoint/Types/Utils.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Utils.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Utils.hi b/dist/build/Language/Fixpoint/Types/Utils.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Utils.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Utils.o b/dist/build/Language/Fixpoint/Types/Utils.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Utils.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Visitor.dyn_hi b/dist/build/Language/Fixpoint/Types/Visitor.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Visitor.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Visitor.dyn_o b/dist/build/Language/Fixpoint/Types/Visitor.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Visitor.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Visitor.hi b/dist/build/Language/Fixpoint/Types/Visitor.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Visitor.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Types/Visitor.o b/dist/build/Language/Fixpoint/Types/Visitor.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Types/Visitor.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Builder.dyn_hi b/dist/build/Language/Fixpoint/Utils/Builder.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Builder.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Builder.dyn_o b/dist/build/Language/Fixpoint/Utils/Builder.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Builder.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Builder.hi b/dist/build/Language/Fixpoint/Utils/Builder.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Builder.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Builder.o b/dist/build/Language/Fixpoint/Utils/Builder.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Builder.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Files.dyn_hi b/dist/build/Language/Fixpoint/Utils/Files.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Files.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Files.dyn_o b/dist/build/Language/Fixpoint/Utils/Files.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Files.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Files.hi b/dist/build/Language/Fixpoint/Utils/Files.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Files.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Files.o b/dist/build/Language/Fixpoint/Utils/Files.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Files.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Progress.dyn_hi b/dist/build/Language/Fixpoint/Utils/Progress.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Progress.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Progress.dyn_o b/dist/build/Language/Fixpoint/Utils/Progress.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Progress.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Progress.hi b/dist/build/Language/Fixpoint/Utils/Progress.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Progress.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Progress.o b/dist/build/Language/Fixpoint/Utils/Progress.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Progress.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Statistics.dyn_hi b/dist/build/Language/Fixpoint/Utils/Statistics.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Statistics.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Statistics.dyn_o b/dist/build/Language/Fixpoint/Utils/Statistics.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Statistics.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Statistics.hi b/dist/build/Language/Fixpoint/Utils/Statistics.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Statistics.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Statistics.o b/dist/build/Language/Fixpoint/Utils/Statistics.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Statistics.o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Trie.dyn_hi b/dist/build/Language/Fixpoint/Utils/Trie.dyn_hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Trie.dyn_hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Trie.dyn_o b/dist/build/Language/Fixpoint/Utils/Trie.dyn_o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Trie.dyn_o and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Trie.hi b/dist/build/Language/Fixpoint/Utils/Trie.hi deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Trie.hi and /dev/null differ diff --git a/dist/build/Language/Fixpoint/Utils/Trie.o b/dist/build/Language/Fixpoint/Utils/Trie.o deleted file mode 100644 Binary files a/dist/build/Language/Fixpoint/Utils/Trie.o and /dev/null differ diff --git a/dist/build/Paths_liquid_fixpoint.dyn_hi b/dist/build/Paths_liquid_fixpoint.dyn_hi deleted file mode 100644 Binary files a/dist/build/Paths_liquid_fixpoint.dyn_hi and /dev/null differ diff --git a/dist/build/Paths_liquid_fixpoint.dyn_o b/dist/build/Paths_liquid_fixpoint.dyn_o deleted file mode 100644 Binary files a/dist/build/Paths_liquid_fixpoint.dyn_o and /dev/null differ diff --git a/dist/build/Paths_liquid_fixpoint.hi b/dist/build/Paths_liquid_fixpoint.hi deleted file mode 100644 Binary files a/dist/build/Paths_liquid_fixpoint.hi and /dev/null differ diff --git a/dist/build/Paths_liquid_fixpoint.o b/dist/build/Paths_liquid_fixpoint.o deleted file mode 100644 Binary files a/dist/build/Paths_liquid_fixpoint.o and /dev/null differ diff --git a/dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_hi b/dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_hi deleted file mode 100644 Binary files a/dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_hi and /dev/null differ diff --git a/dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_o b/dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_o deleted file mode 100644 Binary files a/dist/build/Text/PrettyPrint/HughesPJ/Compat.dyn_o and /dev/null differ diff --git a/dist/build/Text/PrettyPrint/HughesPJ/Compat.hi b/dist/build/Text/PrettyPrint/HughesPJ/Compat.hi deleted file mode 100644 Binary files a/dist/build/Text/PrettyPrint/HughesPJ/Compat.hi and /dev/null differ diff --git a/dist/build/Text/PrettyPrint/HughesPJ/Compat.o b/dist/build/Text/PrettyPrint/HughesPJ/Compat.o deleted file mode 100644 Binary files a/dist/build/Text/PrettyPrint/HughesPJ/Compat.o and /dev/null differ diff --git a/dist/build/autogen/Paths_liquid_fixpoint.hs b/dist/build/autogen/Paths_liquid_fixpoint.hs deleted file mode 100644 --- a/dist/build/autogen/Paths_liquid_fixpoint.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_liquid_fixpoint ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [0,8,10,7] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/niki.vazou/.cabal/bin" -libdir = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF" -dynlibdir = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1" -datadir = "/Users/niki.vazou/.cabal/share/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7" -libexecdir = "/Users/niki.vazou/.cabal/libexec/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7" -sysconfdir = "/Users/niki.vazou/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "liquid_fixpoint_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "liquid_fixpoint_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "liquid_fixpoint_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "liquid_fixpoint_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "liquid_fixpoint_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "liquid_fixpoint_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/dist/build/autogen/cabal_macros.h b/dist/build/autogen/cabal_macros.h deleted file mode 100644 --- a/dist/build/autogen/cabal_macros.h +++ /dev/null @@ -1,495 +0,0 @@ -/* DO NOT EDIT: This file is automatically generated by Cabal */ - -/* package liquid-fixpoint-0.8.10.7 */ -#ifndef VERSION_liquid_fixpoint -#define VERSION_liquid_fixpoint "0.8.10.7" -#endif /* VERSION_liquid_fixpoint */ -#ifndef MIN_VERSION_liquid_fixpoint -#define MIN_VERSION_liquid_fixpoint(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 8 || \ - (major1) == 0 && (major2) == 8 && (minor) <= 10) -#endif /* MIN_VERSION_liquid_fixpoint */ - -/* package base-4.15.0.0 */ -#ifndef VERSION_base -#define VERSION_base "4.15.0.0" -#endif /* VERSION_base */ -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(major1,major2,minor) (\ - (major1) < 4 || \ - (major1) == 4 && (major2) < 15 || \ - (major1) == 4 && (major2) == 15 && (minor) <= 0) -#endif /* MIN_VERSION_base */ - -/* package ansi-terminal-0.11 */ -#ifndef VERSION_ansi_terminal -#define VERSION_ansi_terminal "0.11" -#endif /* VERSION_ansi_terminal */ -#ifndef MIN_VERSION_ansi_terminal -#define MIN_VERSION_ansi_terminal(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 11 || \ - (major1) == 0 && (major2) == 11 && (minor) <= 0) -#endif /* MIN_VERSION_ansi_terminal */ - -/* package array-0.5.4.0 */ -#ifndef VERSION_array -#define VERSION_array "0.5.4.0" -#endif /* VERSION_array */ -#ifndef MIN_VERSION_array -#define MIN_VERSION_array(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 5 || \ - (major1) == 0 && (major2) == 5 && (minor) <= 4) -#endif /* MIN_VERSION_array */ - -/* package async-2.2.4 */ -#ifndef VERSION_async -#define VERSION_async "2.2.4" -#endif /* VERSION_async */ -#ifndef MIN_VERSION_async -#define MIN_VERSION_async(major1,major2,minor) (\ - (major1) < 2 || \ - (major1) == 2 && (major2) < 2 || \ - (major1) == 2 && (major2) == 2 && (minor) <= 4) -#endif /* MIN_VERSION_async */ - -/* package attoparsec-0.14.2 */ -#ifndef VERSION_attoparsec -#define VERSION_attoparsec "0.14.2" -#endif /* VERSION_attoparsec */ -#ifndef MIN_VERSION_attoparsec -#define MIN_VERSION_attoparsec(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 14 || \ - (major1) == 0 && (major2) == 14 && (minor) <= 2) -#endif /* MIN_VERSION_attoparsec */ - -/* package binary-0.8.8.0 */ -#ifndef VERSION_binary -#define VERSION_binary "0.8.8.0" -#endif /* VERSION_binary */ -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 8 || \ - (major1) == 0 && (major2) == 8 && (minor) <= 8) -#endif /* MIN_VERSION_binary */ - -/* package store-0.7.12 */ -#ifndef VERSION_store -#define VERSION_store "0.7.12" -#endif /* VERSION_store */ -#ifndef MIN_VERSION_store -#define MIN_VERSION_store(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 7 || \ - (major1) == 0 && (major2) == 7 && (minor) <= 12) -#endif /* MIN_VERSION_store */ - -/* package bytestring-0.10.12.1 */ -#ifndef VERSION_bytestring -#define VERSION_bytestring "0.10.12.1" -#endif /* VERSION_bytestring */ -#ifndef MIN_VERSION_bytestring -#define MIN_VERSION_bytestring(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 10 || \ - (major1) == 0 && (major2) == 10 && (minor) <= 12) -#endif /* MIN_VERSION_bytestring */ - -/* package boxes-0.1.5 */ -#ifndef VERSION_boxes -#define VERSION_boxes "0.1.5" -#endif /* VERSION_boxes */ -#ifndef MIN_VERSION_boxes -#define MIN_VERSION_boxes(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 1 || \ - (major1) == 0 && (major2) == 1 && (minor) <= 5) -#endif /* MIN_VERSION_boxes */ - -/* package cereal-0.5.8.1 */ -#ifndef VERSION_cereal -#define VERSION_cereal "0.5.8.1" -#endif /* VERSION_cereal */ -#ifndef MIN_VERSION_cereal -#define MIN_VERSION_cereal(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 5 || \ - (major1) == 0 && (major2) == 5 && (minor) <= 8) -#endif /* MIN_VERSION_cereal */ - -/* package cmdargs-0.10.21 */ -#ifndef VERSION_cmdargs -#define VERSION_cmdargs "0.10.21" -#endif /* VERSION_cmdargs */ -#ifndef MIN_VERSION_cmdargs -#define MIN_VERSION_cmdargs(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 10 || \ - (major1) == 0 && (major2) == 10 && (minor) <= 21) -#endif /* MIN_VERSION_cmdargs */ - -/* package containers-0.6.4.1 */ -#ifndef VERSION_containers -#define VERSION_containers "0.6.4.1" -#endif /* VERSION_containers */ -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 6 || \ - (major1) == 0 && (major2) == 6 && (minor) <= 4) -#endif /* MIN_VERSION_containers */ - -/* package deepseq-1.4.5.0 */ -#ifndef VERSION_deepseq -#define VERSION_deepseq "1.4.5.0" -#endif /* VERSION_deepseq */ -#ifndef MIN_VERSION_deepseq -#define MIN_VERSION_deepseq(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 4 || \ - (major1) == 1 && (major2) == 4 && (minor) <= 5) -#endif /* MIN_VERSION_deepseq */ - -/* package directory-1.3.6.1 */ -#ifndef VERSION_directory -#define VERSION_directory "1.3.6.1" -#endif /* VERSION_directory */ -#ifndef MIN_VERSION_directory -#define MIN_VERSION_directory(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 3 || \ - (major1) == 1 && (major2) == 3 && (minor) <= 6) -#endif /* MIN_VERSION_directory */ - -/* package fgl-5.7.0.3 */ -#ifndef VERSION_fgl -#define VERSION_fgl "5.7.0.3" -#endif /* VERSION_fgl */ -#ifndef MIN_VERSION_fgl -#define MIN_VERSION_fgl(major1,major2,minor) (\ - (major1) < 5 || \ - (major1) == 5 && (major2) < 7 || \ - (major1) == 5 && (major2) == 7 && (minor) <= 0) -#endif /* MIN_VERSION_fgl */ - -/* package filepath-1.4.2.1 */ -#ifndef VERSION_filepath -#define VERSION_filepath "1.4.2.1" -#endif /* VERSION_filepath */ -#ifndef MIN_VERSION_filepath -#define MIN_VERSION_filepath(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 4 || \ - (major1) == 1 && (major2) == 4 && (minor) <= 2) -#endif /* MIN_VERSION_filepath */ - -/* package hashable-1.3.3.0 */ -#ifndef VERSION_hashable -#define VERSION_hashable "1.3.3.0" -#endif /* VERSION_hashable */ -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 3 || \ - (major1) == 1 && (major2) == 3 && (minor) <= 3) -#endif /* MIN_VERSION_hashable */ - -/* package intern-0.9.4 */ -#ifndef VERSION_intern -#define VERSION_intern "0.9.4" -#endif /* VERSION_intern */ -#ifndef MIN_VERSION_intern -#define MIN_VERSION_intern(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 9 || \ - (major1) == 0 && (major2) == 9 && (minor) <= 4) -#endif /* MIN_VERSION_intern */ - -/* package mtl-2.2.2 */ -#ifndef VERSION_mtl -#define VERSION_mtl "2.2.2" -#endif /* VERSION_mtl */ -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(major1,major2,minor) (\ - (major1) < 2 || \ - (major1) == 2 && (major2) < 2 || \ - (major1) == 2 && (major2) == 2 && (minor) <= 2) -#endif /* MIN_VERSION_mtl */ - -/* package parallel-3.2.2.0 */ -#ifndef VERSION_parallel -#define VERSION_parallel "3.2.2.0" -#endif /* VERSION_parallel */ -#ifndef MIN_VERSION_parallel -#define MIN_VERSION_parallel(major1,major2,minor) (\ - (major1) < 3 || \ - (major1) == 3 && (major2) < 2 || \ - (major1) == 3 && (major2) == 2 && (minor) <= 2) -#endif /* MIN_VERSION_parallel */ - -/* package parser-combinators-1.3.0 */ -#ifndef VERSION_parser_combinators -#define VERSION_parser_combinators "1.3.0" -#endif /* VERSION_parser_combinators */ -#ifndef MIN_VERSION_parser_combinators -#define MIN_VERSION_parser_combinators(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 3 || \ - (major1) == 1 && (major2) == 3 && (minor) <= 0) -#endif /* MIN_VERSION_parser_combinators */ - -/* package megaparsec-8.0.0 */ -#ifndef VERSION_megaparsec -#define VERSION_megaparsec "8.0.0" -#endif /* VERSION_megaparsec */ -#ifndef MIN_VERSION_megaparsec -#define MIN_VERSION_megaparsec(major1,major2,minor) (\ - (major1) < 8 || \ - (major1) == 8 && (major2) < 0 || \ - (major1) == 8 && (major2) == 0 && (minor) <= 0) -#endif /* MIN_VERSION_megaparsec */ - -/* package pretty-1.1.3.6 */ -#ifndef VERSION_pretty -#define VERSION_pretty "1.1.3.6" -#endif /* VERSION_pretty */ -#ifndef MIN_VERSION_pretty -#define MIN_VERSION_pretty(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 1 || \ - (major1) == 1 && (major2) == 1 && (minor) <= 3) -#endif /* MIN_VERSION_pretty */ - -/* package process-1.6.11.0 */ -#ifndef VERSION_process -#define VERSION_process "1.6.11.0" -#endif /* VERSION_process */ -#ifndef MIN_VERSION_process -#define MIN_VERSION_process(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 6 || \ - (major1) == 1 && (major2) == 6 && (minor) <= 11) -#endif /* MIN_VERSION_process */ - -/* package stm-2.5.0.0 */ -#ifndef VERSION_stm -#define VERSION_stm "2.5.0.0" -#endif /* VERSION_stm */ -#ifndef MIN_VERSION_stm -#define MIN_VERSION_stm(major1,major2,minor) (\ - (major1) < 2 || \ - (major1) == 2 && (major2) < 5 || \ - (major1) == 2 && (major2) == 5 && (minor) <= 0) -#endif /* MIN_VERSION_stm */ - -/* package syb-0.7.2.1 */ -#ifndef VERSION_syb -#define VERSION_syb "0.7.2.1" -#endif /* VERSION_syb */ -#ifndef MIN_VERSION_syb -#define MIN_VERSION_syb(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 7 || \ - (major1) == 0 && (major2) == 7 && (minor) <= 2) -#endif /* MIN_VERSION_syb */ - -/* package text-1.2.4.1 */ -#ifndef VERSION_text -#define VERSION_text "1.2.4.1" -#endif /* VERSION_text */ -#ifndef MIN_VERSION_text -#define MIN_VERSION_text(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 2 || \ - (major1) == 1 && (major2) == 2 && (minor) <= 4) -#endif /* MIN_VERSION_text */ - -/* package transformers-0.5.6.2 */ -#ifndef VERSION_transformers -#define VERSION_transformers "0.5.6.2" -#endif /* VERSION_transformers */ -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 5 || \ - (major1) == 0 && (major2) == 5 && (minor) <= 6) -#endif /* MIN_VERSION_transformers */ - -/* package unordered-containers-0.2.14.0 */ -#ifndef VERSION_unordered_containers -#define VERSION_unordered_containers "0.2.14.0" -#endif /* VERSION_unordered_containers */ -#ifndef MIN_VERSION_unordered_containers -#define MIN_VERSION_unordered_containers(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 2 || \ - (major1) == 0 && (major2) == 2 && (minor) <= 14) -#endif /* MIN_VERSION_unordered_containers */ - -/* package aeson-1.5.6.0 */ -#ifndef VERSION_aeson -#define VERSION_aeson "1.5.6.0" -#endif /* VERSION_aeson */ -#ifndef MIN_VERSION_aeson -#define MIN_VERSION_aeson(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 5 || \ - (major1) == 1 && (major2) == 5 && (minor) <= 6) -#endif /* MIN_VERSION_aeson */ - -/* package rest-rewrite-0.1.1 */ -#ifndef VERSION_rest_rewrite -#define VERSION_rest_rewrite "0.1.1" -#endif /* VERSION_rest_rewrite */ -#ifndef MIN_VERSION_rest_rewrite -#define MIN_VERSION_rest_rewrite(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 1 || \ - (major1) == 0 && (major2) == 1 && (minor) <= 1) -#endif /* MIN_VERSION_rest_rewrite */ - -/* package ascii-progress-0.3.3.0 */ -#ifndef VERSION_ascii_progress -#define VERSION_ascii_progress "0.3.3.0" -#endif /* VERSION_ascii_progress */ -#ifndef MIN_VERSION_ascii_progress -#define MIN_VERSION_ascii_progress(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 3 || \ - (major1) == 0 && (major2) == 3 && (minor) <= 3) -#endif /* MIN_VERSION_ascii_progress */ - -/* tool alex-3.2.4 */ -#ifndef TOOL_VERSION_alex -#define TOOL_VERSION_alex "3.2.4" -#endif /* TOOL_VERSION_alex */ -#ifndef MIN_TOOL_VERSION_alex -#define MIN_TOOL_VERSION_alex(major1,major2,minor) (\ - (major1) < 3 || \ - (major1) == 3 && (major2) < 2 || \ - (major1) == 3 && (major2) == 2 && (minor) <= 4) -#endif /* MIN_TOOL_VERSION_alex */ - -/* tool gcc-12.0.5 */ -#ifndef TOOL_VERSION_gcc -#define TOOL_VERSION_gcc "12.0.5" -#endif /* TOOL_VERSION_gcc */ -#ifndef MIN_TOOL_VERSION_gcc -#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ - (major1) < 12 || \ - (major1) == 12 && (major2) < 0 || \ - (major1) == 12 && (major2) == 0 && (minor) <= 5) -#endif /* MIN_TOOL_VERSION_gcc */ - -/* tool ghc-9.0.1 */ -#ifndef TOOL_VERSION_ghc -#define TOOL_VERSION_ghc "9.0.1" -#endif /* TOOL_VERSION_ghc */ -#ifndef MIN_TOOL_VERSION_ghc -#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ - (major1) < 9 || \ - (major1) == 9 && (major2) < 0 || \ - (major1) == 9 && (major2) == 0 && (minor) <= 1) -#endif /* MIN_TOOL_VERSION_ghc */ - -/* tool ghc-pkg-9.0.1 */ -#ifndef TOOL_VERSION_ghc_pkg -#define TOOL_VERSION_ghc_pkg "9.0.1" -#endif /* TOOL_VERSION_ghc_pkg */ -#ifndef MIN_TOOL_VERSION_ghc_pkg -#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ - (major1) < 9 || \ - (major1) == 9 && (major2) < 0 || \ - (major1) == 9 && (major2) == 0 && (minor) <= 1) -#endif /* MIN_TOOL_VERSION_ghc_pkg */ - -/* tool haddock-2.24.0 */ -#ifndef TOOL_VERSION_haddock -#define TOOL_VERSION_haddock "2.24.0" -#endif /* TOOL_VERSION_haddock */ -#ifndef MIN_TOOL_VERSION_haddock -#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ - (major1) < 2 || \ - (major1) == 2 && (major2) < 24 || \ - (major1) == 2 && (major2) == 24 && (minor) <= 0) -#endif /* MIN_TOOL_VERSION_haddock */ - -/* tool happy-1.19.9 */ -#ifndef TOOL_VERSION_happy -#define TOOL_VERSION_happy "1.19.9" -#endif /* TOOL_VERSION_happy */ -#ifndef MIN_TOOL_VERSION_happy -#define MIN_TOOL_VERSION_happy(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 19 || \ - (major1) == 1 && (major2) == 19 && (minor) <= 9) -#endif /* MIN_TOOL_VERSION_happy */ - -/* tool hpc-0.68 */ -#ifndef TOOL_VERSION_hpc -#define TOOL_VERSION_hpc "0.68" -#endif /* TOOL_VERSION_hpc */ -#ifndef MIN_TOOL_VERSION_hpc -#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 68 || \ - (major1) == 0 && (major2) == 68 && (minor) <= 0) -#endif /* MIN_TOOL_VERSION_hpc */ - -/* tool hsc2hs-0.68.7 */ -#ifndef TOOL_VERSION_hsc2hs -#define TOOL_VERSION_hsc2hs "0.68.7" -#endif /* TOOL_VERSION_hsc2hs */ -#ifndef MIN_TOOL_VERSION_hsc2hs -#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 68 || \ - (major1) == 0 && (major2) == 68 && (minor) <= 7) -#endif /* MIN_TOOL_VERSION_hsc2hs */ - -/* tool hscolour-1.24 */ -#ifndef TOOL_VERSION_hscolour -#define TOOL_VERSION_hscolour "1.24" -#endif /* TOOL_VERSION_hscolour */ -#ifndef MIN_TOOL_VERSION_hscolour -#define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 24 || \ - (major1) == 1 && (major2) == 24 && (minor) <= 0) -#endif /* MIN_TOOL_VERSION_hscolour */ - -/* tool pkg-config-0.29.2 */ -#ifndef TOOL_VERSION_pkg_config -#define TOOL_VERSION_pkg_config "0.29.2" -#endif /* TOOL_VERSION_pkg_config */ -#ifndef MIN_TOOL_VERSION_pkg_config -#define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 29 || \ - (major1) == 0 && (major2) == 29 && (minor) <= 2) -#endif /* MIN_TOOL_VERSION_pkg_config */ - -/* tool runghc-9.0.1 */ -#ifndef TOOL_VERSION_runghc -#define TOOL_VERSION_runghc "9.0.1" -#endif /* TOOL_VERSION_runghc */ -#ifndef MIN_TOOL_VERSION_runghc -#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\ - (major1) < 9 || \ - (major1) == 9 && (major2) < 0 || \ - (major1) == 9 && (major2) == 0 && (minor) <= 1) -#endif /* MIN_TOOL_VERSION_runghc */ - -#ifndef CURRENT_PACKAGE_KEY -#define CURRENT_PACKAGE_KEY "liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF" -#endif /* CURRENT_PACKAGE_KEY */ -#ifndef CURRENT_COMPONENT_ID -#define CURRENT_COMPONENT_ID "liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF" -#endif /* CURRENT_COMPONENT_ID */ -#ifndef CURRENT_PACKAGE_VERSION -#define CURRENT_PACKAGE_VERSION "0.8.10.7" -#endif /* CURRENT_PACKAGE_VERSION */ diff --git a/dist/build/fixpoint/autogen/Paths_liquid_fixpoint.hs b/dist/build/fixpoint/autogen/Paths_liquid_fixpoint.hs deleted file mode 100644 --- a/dist/build/fixpoint/autogen/Paths_liquid_fixpoint.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_liquid_fixpoint ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [0,8,10,7] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/niki.vazou/.cabal/bin" -libdir = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF" -dynlibdir = "/Users/niki.vazou/.cabal/lib/x86_64-osx-ghc-9.0.1" -datadir = "/Users/niki.vazou/.cabal/share/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7" -libexecdir = "/Users/niki.vazou/.cabal/libexec/x86_64-osx-ghc-9.0.1/liquid-fixpoint-0.8.10.7" -sysconfdir = "/Users/niki.vazou/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "liquid_fixpoint_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "liquid_fixpoint_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "liquid_fixpoint_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "liquid_fixpoint_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "liquid_fixpoint_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "liquid_fixpoint_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/dist/build/fixpoint/autogen/cabal_macros.h b/dist/build/fixpoint/autogen/cabal_macros.h deleted file mode 100644 --- a/dist/build/fixpoint/autogen/cabal_macros.h +++ /dev/null @@ -1,162 +0,0 @@ -/* DO NOT EDIT: This file is automatically generated by Cabal */ - -/* package liquid-fixpoint-0.8.10.7 */ -#ifndef VERSION_liquid_fixpoint -#define VERSION_liquid_fixpoint "0.8.10.7" -#endif /* VERSION_liquid_fixpoint */ -#ifndef MIN_VERSION_liquid_fixpoint -#define MIN_VERSION_liquid_fixpoint(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 8 || \ - (major1) == 0 && (major2) == 8 && (minor) <= 10) -#endif /* MIN_VERSION_liquid_fixpoint */ - -/* package base-4.15.0.0 */ -#ifndef VERSION_base -#define VERSION_base "4.15.0.0" -#endif /* VERSION_base */ -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(major1,major2,minor) (\ - (major1) < 4 || \ - (major1) == 4 && (major2) < 15 || \ - (major1) == 4 && (major2) == 15 && (minor) <= 0) -#endif /* MIN_VERSION_base */ - -/* package liquid-fixpoint-0.8.10.7 */ -#ifndef VERSION_liquid_fixpoint -#define VERSION_liquid_fixpoint "0.8.10.7" -#endif /* VERSION_liquid_fixpoint */ -#ifndef MIN_VERSION_liquid_fixpoint -#define MIN_VERSION_liquid_fixpoint(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 8 || \ - (major1) == 0 && (major2) == 8 && (minor) <= 10) -#endif /* MIN_VERSION_liquid_fixpoint */ - -/* tool alex-3.2.4 */ -#ifndef TOOL_VERSION_alex -#define TOOL_VERSION_alex "3.2.4" -#endif /* TOOL_VERSION_alex */ -#ifndef MIN_TOOL_VERSION_alex -#define MIN_TOOL_VERSION_alex(major1,major2,minor) (\ - (major1) < 3 || \ - (major1) == 3 && (major2) < 2 || \ - (major1) == 3 && (major2) == 2 && (minor) <= 4) -#endif /* MIN_TOOL_VERSION_alex */ - -/* tool gcc-12.0.5 */ -#ifndef TOOL_VERSION_gcc -#define TOOL_VERSION_gcc "12.0.5" -#endif /* TOOL_VERSION_gcc */ -#ifndef MIN_TOOL_VERSION_gcc -#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ - (major1) < 12 || \ - (major1) == 12 && (major2) < 0 || \ - (major1) == 12 && (major2) == 0 && (minor) <= 5) -#endif /* MIN_TOOL_VERSION_gcc */ - -/* tool ghc-9.0.1 */ -#ifndef TOOL_VERSION_ghc -#define TOOL_VERSION_ghc "9.0.1" -#endif /* TOOL_VERSION_ghc */ -#ifndef MIN_TOOL_VERSION_ghc -#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ - (major1) < 9 || \ - (major1) == 9 && (major2) < 0 || \ - (major1) == 9 && (major2) == 0 && (minor) <= 1) -#endif /* MIN_TOOL_VERSION_ghc */ - -/* tool ghc-pkg-9.0.1 */ -#ifndef TOOL_VERSION_ghc_pkg -#define TOOL_VERSION_ghc_pkg "9.0.1" -#endif /* TOOL_VERSION_ghc_pkg */ -#ifndef MIN_TOOL_VERSION_ghc_pkg -#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ - (major1) < 9 || \ - (major1) == 9 && (major2) < 0 || \ - (major1) == 9 && (major2) == 0 && (minor) <= 1) -#endif /* MIN_TOOL_VERSION_ghc_pkg */ - -/* tool haddock-2.24.0 */ -#ifndef TOOL_VERSION_haddock -#define TOOL_VERSION_haddock "2.24.0" -#endif /* TOOL_VERSION_haddock */ -#ifndef MIN_TOOL_VERSION_haddock -#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ - (major1) < 2 || \ - (major1) == 2 && (major2) < 24 || \ - (major1) == 2 && (major2) == 24 && (minor) <= 0) -#endif /* MIN_TOOL_VERSION_haddock */ - -/* tool happy-1.19.9 */ -#ifndef TOOL_VERSION_happy -#define TOOL_VERSION_happy "1.19.9" -#endif /* TOOL_VERSION_happy */ -#ifndef MIN_TOOL_VERSION_happy -#define MIN_TOOL_VERSION_happy(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 19 || \ - (major1) == 1 && (major2) == 19 && (minor) <= 9) -#endif /* MIN_TOOL_VERSION_happy */ - -/* tool hpc-0.68 */ -#ifndef TOOL_VERSION_hpc -#define TOOL_VERSION_hpc "0.68" -#endif /* TOOL_VERSION_hpc */ -#ifndef MIN_TOOL_VERSION_hpc -#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 68 || \ - (major1) == 0 && (major2) == 68 && (minor) <= 0) -#endif /* MIN_TOOL_VERSION_hpc */ - -/* tool hsc2hs-0.68.7 */ -#ifndef TOOL_VERSION_hsc2hs -#define TOOL_VERSION_hsc2hs "0.68.7" -#endif /* TOOL_VERSION_hsc2hs */ -#ifndef MIN_TOOL_VERSION_hsc2hs -#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 68 || \ - (major1) == 0 && (major2) == 68 && (minor) <= 7) -#endif /* MIN_TOOL_VERSION_hsc2hs */ - -/* tool hscolour-1.24 */ -#ifndef TOOL_VERSION_hscolour -#define TOOL_VERSION_hscolour "1.24" -#endif /* TOOL_VERSION_hscolour */ -#ifndef MIN_TOOL_VERSION_hscolour -#define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 24 || \ - (major1) == 1 && (major2) == 24 && (minor) <= 0) -#endif /* MIN_TOOL_VERSION_hscolour */ - -/* tool pkg-config-0.29.2 */ -#ifndef TOOL_VERSION_pkg_config -#define TOOL_VERSION_pkg_config "0.29.2" -#endif /* TOOL_VERSION_pkg_config */ -#ifndef MIN_TOOL_VERSION_pkg_config -#define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 29 || \ - (major1) == 0 && (major2) == 29 && (minor) <= 2) -#endif /* MIN_TOOL_VERSION_pkg_config */ - -/* tool runghc-9.0.1 */ -#ifndef TOOL_VERSION_runghc -#define TOOL_VERSION_runghc "9.0.1" -#endif /* TOOL_VERSION_runghc */ -#ifndef MIN_TOOL_VERSION_runghc -#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\ - (major1) < 9 || \ - (major1) == 9 && (major2) < 0 || \ - (major1) == 9 && (major2) == 0 && (minor) <= 1) -#endif /* MIN_TOOL_VERSION_runghc */ - -#ifndef CURRENT_COMPONENT_ID -#define CURRENT_COMPONENT_ID "liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-fixpoint" -#endif /* CURRENT_COMPONENT_ID */ -#ifndef CURRENT_PACKAGE_VERSION -#define CURRENT_PACKAGE_VERSION "0.8.10.7" -#endif /* CURRENT_PACKAGE_VERSION */ diff --git a/dist/build/fixpoint/fixpoint b/dist/build/fixpoint/fixpoint deleted file mode 100644 # file too large to diff: dist/build/fixpoint/fixpoint diff --git a/dist/build/fixpoint/fixpoint-tmp/Main.hi b/dist/build/fixpoint/fixpoint-tmp/Main.hi deleted file mode 100644 Binary files a/dist/build/fixpoint/fixpoint-tmp/Main.hi and /dev/null differ diff --git a/dist/build/fixpoint/fixpoint-tmp/Main.o b/dist/build/fixpoint/fixpoint-tmp/Main.o deleted file mode 100644 Binary files a/dist/build/fixpoint/fixpoint-tmp/Main.o and /dev/null differ diff --git a/dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-ghc9.0.1.dylib b/dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-ghc9.0.1.dylib deleted file mode 100644 # file too large to diff: dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF-ghc9.0.1.dylib diff --git a/dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.a b/dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.a deleted file mode 100644 # file too large to diff: dist/build/libHSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.a diff --git a/dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM-ghc9.0.1.dylib b/dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM-ghc9.0.1.dylib deleted file mode 100644 # file too large to diff: dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM-ghc9.0.1.dylib diff --git a/dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM.a b/dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM.a deleted file mode 100644 # file too large to diff: dist/build/libHSliquid-fixpoint-0.8.10.7.1-K8pospJxO6RGfsweTfekAM.a diff --git a/dist/package.conf.inplace/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.conf b/dist/package.conf.inplace/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.conf deleted file mode 100644 --- a/dist/package.conf.inplace/liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF.conf +++ /dev/null @@ -1,126 +0,0 @@ -name: liquid-fixpoint -version: 0.8.10.7 -id: liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF -key: liquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF -license: BSD-3-Clause -copyright: 2010-17 Ranjit Jhala, University of California, San Diego. -maintainer: jhala@cs.ucsd.edu -author: Ranjit Jhala, Niki Vazou, Eric Seidel -homepage: https://github.com/ucsd-progsys/liquid-fixpoint -synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver -description: - This package implements an SMTLIB based Horn-Clause\/Logical Implication constraint - solver used for Liquid Types. - . - The package includes: - . - 1. Types for Expressions, Predicates, Constraints, Solutions - 2. Code for solving constraints - . - Requirements - . - In addition to the .cabal dependencies you require - . - * A Z3 () or CVC4 () binary. -category: Language -abi: inplace -exposed: True -exposed-modules: - Data.ShareMap Language.Fixpoint.Defunctionalize - Language.Fixpoint.Graph Language.Fixpoint.Graph.Deps - Language.Fixpoint.Graph.Indexed Language.Fixpoint.Graph.Partition - Language.Fixpoint.Graph.Reducible Language.Fixpoint.Graph.Types - Language.Fixpoint.Horn.Info Language.Fixpoint.Horn.Parse - Language.Fixpoint.Horn.Solve Language.Fixpoint.Horn.Transformations - Language.Fixpoint.Horn.Types Language.Fixpoint.Minimize - Language.Fixpoint.Misc Language.Fixpoint.Parse - Language.Fixpoint.Smt.Bitvector Language.Fixpoint.Smt.Interface - Language.Fixpoint.Smt.Serialize Language.Fixpoint.Smt.Theories - Language.Fixpoint.Smt.Types Language.Fixpoint.Solver - Language.Fixpoint.Solver.Eliminate - Language.Fixpoint.Solver.EnvironmentReduction - Language.Fixpoint.Solver.Extensionality - Language.Fixpoint.Solver.GradualSolution - Language.Fixpoint.Solver.Instantiate Language.Fixpoint.Solver.Monad - Language.Fixpoint.Solver.PLE Language.Fixpoint.Solver.Prettify - Language.Fixpoint.Solver.Rewrite Language.Fixpoint.Solver.Sanitize - Language.Fixpoint.Solver.Solution Language.Fixpoint.Solver.Solve - Language.Fixpoint.Solver.Stats Language.Fixpoint.Solver.TrivialSort - Language.Fixpoint.Solver.UniqifyBinds - Language.Fixpoint.Solver.UniqifyKVars - Language.Fixpoint.Solver.Worklist Language.Fixpoint.SortCheck - Language.Fixpoint.Types Language.Fixpoint.Types.Config - Language.Fixpoint.Types.Constraints - Language.Fixpoint.Types.Environments Language.Fixpoint.Types.Errors - Language.Fixpoint.Types.Graduals Language.Fixpoint.Types.Names - Language.Fixpoint.Types.PrettyPrint - Language.Fixpoint.Types.Refinements - Language.Fixpoint.Types.Solutions Language.Fixpoint.Types.Sorts - Language.Fixpoint.Types.Spans Language.Fixpoint.Types.Substitutions - Language.Fixpoint.Types.Templates Language.Fixpoint.Types.Theories - Language.Fixpoint.Types.Triggers Language.Fixpoint.Types.Utils - Language.Fixpoint.Types.Visitor Language.Fixpoint.Utils.Builder - Language.Fixpoint.Utils.Files Language.Fixpoint.Utils.Progress - Language.Fixpoint.Utils.Statistics Language.Fixpoint.Utils.Trie - Text.PrettyPrint.HughesPJ.Compat -hidden-modules: Paths_liquid_fixpoint -import-dirs: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/build -library-dirs: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/build -dynamic-library-dirs: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/build -data-dir: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7 -hs-libraries: HSliquid-fixpoint-0.8.10.7-FgCIsJqmD5EU4mf5QzNnF -depends: - base-4.15.0.0 ansi-terminal-0.11-DOUngjGM5e9DBdxKKdJoVq - array-0.5.4.0 async-2.2.4-JeDGkdQL92SGvrTcykFE1G - attoparsec-0.14.2-GRB4tkqiZ1lJ3VDtKSiDmp binary-0.8.8.0 - store-0.7.12-1jDuo34RRHF1Hy2bG8VuHK bytestring-0.10.12.1 - boxes-0.1.5-C3Kz8ochWvU21KQ3vfFzqc - cereal-0.5.8.1-1rEYQzBD8E9DIUYY4RFjl8 - cmdargs-0.10.21-9JSptK8vQ5KGyQ5LWB6hlS containers-0.6.4.1 - deepseq-1.4.5.0 directory-1.3.6.1 - fgl-5.7.0.3-5OLLFynJZSREnalnrodEAD filepath-1.4.2.1 - hashable-1.3.3.0-D0do58bNrPk5L3yCngfJJ3 - intern-0.9.4-FjOGVQc5D9A9cT7GJ3znV mtl-2.2.2 - parallel-3.2.2.0-G9JTeCQCHda2yggytvFxi6 - parser-combinators-1.3.0-5jHqYWwdpCqFWQLuYLRvi6 - megaparsec-8.0.0-HpfmBpBmwaA25sr4odFZpU pretty-1.1.3.6 - process-1.6.11.0 stm-2.5.0.0 syb-0.7.2.1-1KAKIfi7jVfHb7rx2ko4wD - text-1.2.4.1 transformers-0.5.6.2 - unordered-containers-0.2.14.0-L4skvY6vsWn5C5vZMnj1cY - aeson-1.5.6.0-DHNSyhPFyS5bKQzGnVe65 - rest-rewrite-0.1.1-ExUfTOXktU57vIN1mThfaz - ascii-progress-0.3.3.0-IvDhgho0XVI68QREgihigY -abi-depends: base-4.15.0.0=02cb1f9c5fbe783ec723114554c1a1bd - ansi-terminal-0.11-DOUngjGM5e9DBdxKKdJoVq=d6c3710fa9fda55e0ebacd6cce99c895 - array-0.5.4.0=9a81a071217c73ead314239d931f3539 - async-2.2.4-JeDGkdQL92SGvrTcykFE1G=9b04d03d55892f910c05c503857c8315 - attoparsec-0.14.2-GRB4tkqiZ1lJ3VDtKSiDmp=1ac805cba81d1b6a4027ddfaa73a0f02 - binary-0.8.8.0=b29e0271e764eded9a7fe7f7efb29a00 - store-0.7.12-1jDuo34RRHF1Hy2bG8VuHK=3e81e9e2248a6603e4466219b77c99a6 - bytestring-0.10.12.1=bcf6a61abaf149418191c5b82a3f1f35 - boxes-0.1.5-C3Kz8ochWvU21KQ3vfFzqc=cb68f89029edf9163997bd4a9a25ebfb - cereal-0.5.8.1-1rEYQzBD8E9DIUYY4RFjl8=9ad34802ac104316d41f1cbf1a6f5519 - cmdargs-0.10.21-9JSptK8vQ5KGyQ5LWB6hlS=9851f7363467bc98ccd2b7a763752398 - containers-0.6.4.1=9fdc55ef8690ff523eba389e5f991c4e - deepseq-1.4.5.0=a3c53cf199b05b32e32750439c1fb094 - directory-1.3.6.1=69c9abca6e0cbd58b5dff3b7cc43d204 - fgl-5.7.0.3-5OLLFynJZSREnalnrodEAD=fbe6b7290463c97154a639b024be851a - filepath-1.4.2.1=4dba1196734519d5fa5937d656a5f36a - hashable-1.3.3.0-D0do58bNrPk5L3yCngfJJ3=30065752580855fe6ccd81f3bc4efcdd - intern-0.9.4-FjOGVQc5D9A9cT7GJ3znV=657da685930e1d1a9dc583e8d6b2c5c7 - mtl-2.2.2=dbb5a8013d6af5aeb8382ab9f42b23e5 - parallel-3.2.2.0-G9JTeCQCHda2yggytvFxi6=639a5f668a4d607f889d7d7a865c37d8 - parser-combinators-1.3.0-5jHqYWwdpCqFWQLuYLRvi6=570d649fbaa64c76c448aba32cebadfb - megaparsec-8.0.0-HpfmBpBmwaA25sr4odFZpU=7f6082726fd5ed2300d912861bbf6b71 - pretty-1.1.3.6=991926efc506d871d2b1df02dd84a1f3 - process-1.6.11.0=106f5dc09262f5ff85248631dfdbd424 - stm-2.5.0.0=1907802766f953b2b67d72785a26bcec - syb-0.7.2.1-1KAKIfi7jVfHb7rx2ko4wD=5edc1b6becc78a39dd5d32482fc47761 - text-1.2.4.1=d3af972311c726304b525c2c823214fe - transformers-0.5.6.2=6d61a65a7ab8e1f3ab98b9bf5aeaa056 - unordered-containers-0.2.14.0-L4skvY6vsWn5C5vZMnj1cY=869782fc6ea4d62ed36ae1c1536579d2 - aeson-1.5.6.0-DHNSyhPFyS5bKQzGnVe65=6425135f2ca91e6567b795bd3be87c9d - rest-rewrite-0.1.1-ExUfTOXktU57vIN1mThfaz=4183a6c474b6a786b4d68be96afecbf5 - ascii-progress-0.3.3.0-IvDhgho0XVI68QREgihigY=c414b11a060f16e2c462cc641b7d66ec -haddock-interfaces: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/doc/html/liquid-fixpoint/liquid-fixpoint.haddock -haddock-html: /Users/niki.vazou/liquidtypes/release/liquid-fixpoint-0.8.10.7/dist/doc/html/liquid-fixpoint diff --git a/dist/package.conf.inplace/package.cache b/dist/package.conf.inplace/package.cache deleted file mode 100644 Binary files a/dist/package.conf.inplace/package.cache and /dev/null differ diff --git a/dist/package.conf.inplace/package.cache.lock b/dist/package.conf.inplace/package.cache.lock deleted file mode 100644 --- a/dist/package.conf.inplace/package.cache.lock +++ /dev/null diff --git a/dist/setup-config b/dist/setup-config deleted file mode 100644 Binary files a/dist/setup-config and /dev/null differ diff --git a/git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch b/git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch deleted file mode 100644 --- a/git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch +++ /dev/null @@ -1,13 +0,0 @@ -diff --git a/Data/Git/Monad.hs b/Data/Git/Monad.hs -index 480af9f..27c3b3e 100644 ---- a/Data/Git/Monad.hs -+++ b/Data/Git/Monad.hs -@@ -130 +130 @@ instance Resolvable Git.RefName where --class (Functor m, Applicative m, Monad m) => GitMonad m where -+class (Functor m, Applicative m, Monad m, MonadFail m) => GitMonad m where -@@ -242,0 +243 @@ instance Monad GitM where -+instance MonadFail GitM where -@@ -315,0 +317 @@ instance Monad CommitAccessM where -+instance MonadFail CommitAccessM where -@@ -476,0 +479 @@ instance Monad CommitM where -+instance MonadFail CommitM where diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 --- a/hie.yaml +++ /dev/null @@ -1,8 +0,0 @@ -cradle: - stack: - - path: "./src" - component: "liquid-fixpoint:lib" - - path: "./bin" - component: "liquid-fixpoint:exe:fixpoint" - - path: "./tests" - component: "liquid-fixpoint:test:test" diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.2 +cabal-version: 2.4 name: liquid-fixpoint -version: 0.8.10.7 +version: 0.9.0.2.1 synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver description: This package implements an SMTLIB based Horn-Clause\/Logical Implication constraint @@ -16,15 +16,16 @@ In addition to the .cabal dependencies you require . * A Z3 () or CVC4 () binary. -license: BSD-3-Clause -license-file: LICENSE -copyright: 2010-17 Ranjit Jhala, University of California, San Diego. +category: Language +homepage: https://github.com/ucsd-progsys/liquid-fixpoint#readme +bug-reports: https://github.com/ucsd-progsys/liquid-fixpoint/issues author: Ranjit Jhala, Niki Vazou, Eric Seidel maintainer: jhala@cs.ucsd.edu -tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.3, GHC == 8.6.4, GHC == 8.10.1, GHC == 8.10.7 -category: Language -homepage: https://github.com/ucsd-progsys/liquid-fixpoint +copyright: 2010-17 Ranjit Jhala, University of California, San Diego. +license: BSD-3-Clause +license-file: LICENSE build-type: Simple +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.3, GHC == 8.6.4, GHC == 8.10.1, GHC == 8.10.7 extra-source-files: tests/neg/*.fq tests/pos/*.fq unix/Language/Fixpoint/Utils/*.hs @@ -32,17 +33,21 @@ tests/logs/cur/pin Makefile +common warnings + ghc-options: + -Wall + source-repository head - type: git - location: https://github.com/ucsd-progsys/liquid-fixpoint/ + type: git + location: https://github.com/ucsd-progsys/liquid-fixpoint flag devel - default: False - manual: True description: turn on stricter error reporting for development + manual: True + default: False library - autogen-modules: Paths_liquid_fixpoint + import: warnings exposed-modules: Data.ShareMap Language.Fixpoint.Defunctionalize Language.Fixpoint.Graph @@ -51,11 +56,11 @@ Language.Fixpoint.Graph.Partition Language.Fixpoint.Graph.Reducible Language.Fixpoint.Graph.Types + Language.Fixpoint.Horn.Info Language.Fixpoint.Horn.Parse Language.Fixpoint.Horn.Solve - Language.Fixpoint.Horn.Types Language.Fixpoint.Horn.Transformations - Language.Fixpoint.Horn.Info + Language.Fixpoint.Horn.Types Language.Fixpoint.Minimize Language.Fixpoint.Misc Language.Fixpoint.Parse @@ -65,15 +70,20 @@ Language.Fixpoint.Smt.Theories Language.Fixpoint.Smt.Types Language.Fixpoint.Solver + Language.Fixpoint.Solver.Common Language.Fixpoint.Solver.Eliminate Language.Fixpoint.Solver.EnvironmentReduction + Language.Fixpoint.Solver.Extensionality Language.Fixpoint.Solver.GradualSolution + Language.Fixpoint.Solver.GradualSolve Language.Fixpoint.Solver.Instantiate - Language.Fixpoint.Solver.PLE + Language.Fixpoint.Solver.Interpreter Language.Fixpoint.Solver.Monad - Language.Fixpoint.Solver.Rewrite + Language.Fixpoint.Solver.PLE Language.Fixpoint.Solver.Prettify + Language.Fixpoint.Solver.Rewrite Language.Fixpoint.Solver.Sanitize + Language.Fixpoint.Solver.Simplify Language.Fixpoint.Solver.Solution Language.Fixpoint.Solver.Solve Language.Fixpoint.Solver.Stats @@ -81,7 +91,6 @@ Language.Fixpoint.Solver.UniqifyBinds Language.Fixpoint.Solver.UniqifyKVars Language.Fixpoint.Solver.Worklist - Language.Fixpoint.Solver.Extensionality Language.Fixpoint.SortCheck Language.Fixpoint.Types Language.Fixpoint.Types.Config @@ -108,16 +117,18 @@ Language.Fixpoint.Utils.Trie Text.PrettyPrint.HughesPJ.Compat other-modules: Paths_liquid_fixpoint + autogen-modules: Paths_liquid_fixpoint hs-source-dirs: src - build-depends: base >= 4.9.1.0 && < 5 + ghc-options: -W -Wno-missing-methods -Wmissing-signatures + build-depends: aeson , ansi-terminal , array , async , attoparsec + , base >= 4.9.1.0 && < 5 , binary - , store - , bytestring , boxes + , bytestring , cereal , cmdargs , containers @@ -125,86 +136,101 @@ , directory , fgl , filepath - , hashable >=1.3 && <1.3.4 + , hashable , intern + , lens-family + , megaparsec >= 7.0.0 && < 10 , mtl , parallel , parser-combinators - , megaparsec >= 7.0.0 && < 9 , pretty >= 1.1.3.1 , process + , rest-rewrite >= 0.3.0 , stm - , syb + , store + , vector < 0.13 , syb , text , transformers , unordered-containers - , aeson - , rest-rewrite >= 0.1.1 - default-language: Haskell98 - ghc-options: -W -fno-warn-missing-methods -fwarn-missing-signatures + ghc-options: + -fwrite-ide-info + -hiedir=.hie if flag(devel) ghc-options: -Werror - if !os(windows) hs-source-dirs: unix build-depends: ascii-progress >= 0.3 - if os(windows) hs-source-dirs: win + default-language: Haskell98 executable fixpoint + import: warnings main-is: Fixpoint.hs + other-modules: Paths_liquid_fixpoint + autogen-modules: Paths_liquid_fixpoint hs-source-dirs: bin + ghc-options: -threaded -W -Wno-missing-methods build-depends: base >= 4.9.1.0 && < 5, liquid-fixpoint - default-language: Haskell98 - ghc-options: -threaded -W -fno-warn-missing-methods - if flag(devel) ghc-options: -Werror + default-language: Haskell98 test-suite test + import: warnings type: exitcode-stdio-1.0 main-is: test.hs other-modules: Paths_liquid_fixpoint + autogen-modules: Paths_liquid_fixpoint hs-source-dirs: tests - build-tool-depends: liquid-fixpoint:fixpoint + ghc-options: -threaded build-depends: base >= 4.9.1.0 && < 5 , containers >= 0.5 , directory , filepath , mtl >= 2.2.2 + , optparse-applicative , process , stm >= 2.4 + , tagged , tasty >= 0.10 , tasty-ant-xml - , tasty-hunit , tasty-hunit >= 0.9 , tasty-rerun >= 1.1.12 , transformers >= 0.5 - default-language: Haskell98 - ghc-options: -threaded - if flag(devel) ghc-options: -Werror + build-tool-depends: liquid-fixpoint:fixpoint + default-language: Haskell98 test-suite tasty + import: warnings type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: ParserTests + other-modules: Arbitrary + InterpretTests + ParserTests ShareMapReference ShareMapTests + SimplifyInterpreter + SimplifyPLE + SimplifyTests + UndoANFTests + Paths_liquid_fixpoint + autogen-modules: Paths_liquid_fixpoint hs-source-dirs: tests/tasty + ghc-options: -threaded build-depends: base >= 4.9.1.0 && < 5 - , hashable >=1.3 && <1.3.4 + , containers + , hashable , liquid-fixpoint , tasty >= 0.10 - , tasty-quickcheck , tasty-hunit >= 0.9 + , tasty-quickcheck + , text , unordered-containers - default-language: Haskell98 - ghc-options: -threaded - if flag(devel) ghc-options: -Werror + default-language: Haskell98 diff --git a/scripts/travis b/scripts/travis deleted file mode 100644 --- a/scripts/travis +++ /dev/null @@ -1,137 +0,0 @@ -#!/bin/bash - -set -eu -set -o pipefail - -## Helper Functions - -function loud { - echo "$ $@" - $@ -} - -# Source: https://github.com/travis-ci/travis-build/blob/fc4ae8a2ffa1f2b3a2f62533bbc4f8a9be19a8ae/lib/travis/build/script/templates/header.sh#L104-L123 -RED="\033[31;1m" -GREEN="\033[32;1m" -RESET="\033[0m" -function travis_retry { - local result=0 - local count=1 - while [ $count -le 3 ]; do - [ $result -ne 0 ] && { - echo -e "\n${RED}The command \"$@\" failed. Retrying, $count of 3.${RESET}\n" >&2 - } - set +e - "$@" - result=$? - set -e - [ $result -eq 0 ] && break - count=$(($count + 1)) - sleep 1 - done - - [ $count -eq 4 ] && { - echo "\n${RED}The command \"$@\" failed 3 times.${RESET}\n" >&2 - } - - return $result -} - -function prevent_timeout { - local cmd="$@" - - $cmd & - local cmd_pid=$! - - poke_stdout & - local poke_pid=$! - - wait $cmd_pid - exit_code=$? - - kill $poke_pid - (wait $poke_pid 2>/dev/null) || true - - return $exit_code -} - -function poke_stdout { - # Print an invisible character every minute - while true; do - echo -ne "\xE2\x80\x8B" - sleep 60 - done -} - -function pastebin { - curl -s -F 'clbin=<-' https://clbin.com -} - -## Testing Stages - -function clean_cache { - local smt="$1" - - loud ghc-pkg unregister liquid-fixpoint --force || true - loud rm "$HOME/.cabal/bin/$smt" || true -} - -function install_smt { - local smt="$1" - - mkdir -p "$HOME/.cabal/bin" - loud curl "http://goto.ucsd.edu/~gridaphobe/$smt" -o "$HOME/.cabal/bin/$smt" - loud chmod a+x "$HOME/.cabal/bin/$smt" -} - -function install_cabal_deps { - if ! _install_cabal_deps; then - echo " ==> Cabal install failed. Clearing dependency cache and retrying." - loud rm -rf "$HOME/.cabal" - loud rm -rf "$HOME/.ghc" - _install_cabal_deps - fi -} - -function _install_cabal_deps { - loud travis_retry cabal update || return 1 - loud travis_retry cabal install --only-dependencies --enable-tests || return 1 -} - -function do_build { - loud cabal configure -fbuild-external --enable-tests -v2 - loud prevent_timeout cabal build -j2 - loud cabal haddock -} - -function do_test { - loud prevent_timeout ./dist/build/test/test -} - -function dump_fail_logs { - find . -type f -wholename '*/.liquid/*' -name '*.log' -print0 | while IFS= read -r -d $'\0' file; do - echo "${file}:" - echo " $(pastebin < "${file}")" - done -} - -function test_source_pkg { - loud cabal sdist - - local src_tgz="dist/$(cabal info . | awk '{print $2 ".tar.gz";exit}')" - - if [ -f "$src_tgz" ]; then - loud prevent_timeout cabal install -j4 "$src_tgz" - else - echo "expected '$src_tgz' not found" - return 1 - fi -} - -## Run Test Stage - -stage="$1" -shift - -$stage "$@" - diff --git a/shell.nix b/shell.nix deleted file mode 100644 --- a/shell.nix +++ /dev/null @@ -1,1 +0,0 @@ -import ./. { makeEnv = true; } diff --git a/src/Language/Fixpoint/Congruence/Closure.hs b/src/Language/Fixpoint/Congruence/Closure.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Congruence/Closure.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Language.Fixpoint.Congruence.Closure where - --- import Data.Hashable -import Data.Interned -import Control.Monad --- import Control.Monad.Except -- (MonadError(..)) -import Control.Monad.State.Strict -import qualified Data.HashMap.Strict as M -import Language.Fixpoint.Congruence.Types -import Language.Fixpoint.Misc (ifM) - -sat :: CongQuery -> Bool -sat = undefined - -type UF = State UFState - -data UFState = U - { ufPar :: M.HashMap Id Term -- ^ i :-> t IF term 'i' has union-find parent 't' - , ufPreds :: M.HashMap Id [(Int, Term)] -- ^ i :-> (j, t) IF term 'i' is 'j'-th arg in application 't' - } - -parent :: Term -> UF (Maybe Term) -parent u = M.lookup (identity u) <$> gets ufPar - -find :: Term -> UF Id -find u = do - mbU' <- parent u - case mbU' of - Nothing -> return (identity u) - Just u' -> find u' - -union :: Term -> Term -> UF () -union _u _v = undefined -- _TODO - -preds :: Id -> UF [(Int, Term)] -preds = undefined -- _TODO - -isCong :: Term -> Term -> UF Bool -isCong = undefined -- _TODO - -isEq :: Term -> Term -> UF Bool -isEq u v = do - ui <- find u - vi <- find v - return (ui == vi) - -congMerge :: (Int, Term) -> (Int, Term) -> UF () -congMerge (i, u) (j, v) - | i == j = ifM (isEq u v) - (return ()) - (ifM (isCong u v) - (merge u v) - (return ())) - | otherwise = return () - -merge :: Term -> Term -> UF () -merge u v = do - ui <- find u - vi <- find v - unless (ui == vi) $ do - uPs <- preds ui - vPs <- preds vi - union u v - forM_ uPs $ \u' -> - forM_ vPs $ \v' -> - congMerge u' v' - diff --git a/src/Language/Fixpoint/Congruence/Types.hs b/src/Language/Fixpoint/Congruence/Types.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Congruence/Types.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Fixpoint.Congruence.Types - ( -- * Queries - CongQuery (..) - , Equality (..) - , Disequality (..) - - -- * Terms - , Term - , identity - - -- * Constructors - , app - , var - ) where - -import Data.Function (on) -import Data.Hashable -import Data.Interned - -import qualified Language.Fixpoint.Types as F - --- 1. x = y => f x = f y --- 2. f(f(f(x))) = x => f(f(f(f(f(x))))) = x => f(x) = a - -_examples = [t1, t2] - where - t1 = app "f" [var "x", var "y"] - t2 = app "f" [var "x", var "y"] - -data CongQuery = Query [Equality] [Disequality] -data Equality = Eq Term Term -data Disequality = Diseq Term Term - --------------------------------------------------------------------------------- --- | Exported Constructors --------------------------------------------------------------------------------- -app :: F.Symbol -> [Term] -> Term -app f as = intern (BApp f as) - -var :: F.Symbol -> Term -var x = intern (BVar x) - --------------------------------------------------------------------------------- --- | Hash-consed Term DataType --------------------------------------------------------------------------------- -data Term - = Var {-# UNPACK #-} !Id !F.Symbol - | App {-# UNPACK #-} !Id !F.Symbol [Term] --------------------------------------------------------------------------------- - -data UninternedTerm - = BVar !F.Symbol - | BApp !F.Symbol [Term] - -instance Interned Term where - type Uninterned Term = UninternedTerm - data Description Term = DVar F.Symbol - | DApp F.Symbol [Id] - deriving Show - describe (BApp f as) = DApp f (identity <$> as) - describe (BVar x) = DVar x - identify i = go - where - go (BApp f as) = App i f as - go (BVar x) = Var i x - - cache = termCache - -identity :: Term -> Id -identity (App i _ _) = i -identity (Var i _) = i - -instance Uninternable Term where - unintern (App _ f as) = BApp f as - unintern (Var _ x) = BVar x - -termCache :: Cache Term -termCache = mkCache -{-# NOINLINE termCache #-} - -instance Eq (Description Term) where - DApp f as == DApp f' as' = f == f' && as == as' - DVar x == DVar x' = x == x' - _ == _ = False - -instance Hashable (Description Term) where - hashWithSalt s (DApp f a) = s `hashWithSalt` (0 :: Int) `hashWithSalt` f `hashWithSalt` a - hashWithSalt s (DVar n) = s `hashWithSalt` (3 :: Int) `hashWithSalt` n - -instance Eq Term where - (==) = (==) `on` identity - -instance Ord Term where - compare = compare `on` identity - diff --git a/src/Language/Fixpoint/Defunctionalize.hs b/src/Language/Fixpoint/Defunctionalize.hs --- a/src/Language/Fixpoint/Defunctionalize.hs +++ b/src/Language/Fixpoint/Defunctionalize.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -------------------------------------------------------------------------------- -- | `defunctionalize` traverses the query to: -- 1. "normalize" lambda terms by renaming binders, @@ -18,18 +18,19 @@ -- `EApp` and `ELam` to determine the lambdas and redexes. -------------------------------------------------------------------------------- -module Language.Fixpoint.Defunctionalize +module Language.Fixpoint.Defunctionalize ( defunctionalize , Defunc(..) , defuncAny - ) where + ) where import qualified Data.HashMap.Strict as M import Data.Hashable import Control.Monad.State import Language.Fixpoint.Misc (fM, secondM, mapSnd) import Language.Fixpoint.Solver.Sanitize (symbolEnv) -import Language.Fixpoint.Types hiding (allowHO) +import Language.Fixpoint.Types hiding (GInfo(..), allowHO, fi) +import qualified Language.Fixpoint.Types as Types (GInfo(..)) import Language.Fixpoint.Types.Config import Language.Fixpoint.Types.Visitor (mapMExpr) -- import Debug.Trace (trace) @@ -54,7 +55,7 @@ >=> mapMExpr (fM normalizeLams) reBind :: Expr -> DF Expr -reBind (ELam (x, s) e) = ((\y -> ELam (y, s) (subst1 e (x, EVar y))) <$> freshSym s) +reBind (ELam (x, s) e) = (\y -> ELam (y, s) (subst1 e (x, EVar y))) <$> freshSym s reBind e = return e shiftLam :: Int -> Symbol -> Sort -> Expr -> Expr shiftLam i x t e = ELam (x_i, t) (e `subst1` (x, x_i_t)) @@ -62,7 +63,10 @@ x_i = lamArgSymbol i x_i_t = ECst (EVar x_i) t --- normalize lambda arguments [TODO: example] +-- | normalize lambda arguments [TODO: example] +-- +-- Renames lambda bindings to lamb_arg##i. Each use of a lambda binding +-- is surrounded with a cast. normalizeLams :: Expr -> Expr normalizeLams e = snd $ normalizeLamsFromTo 1 e @@ -70,7 +74,7 @@ normalizeLamsFromTo :: Int -> Expr -> (Int, Expr) normalizeLamsFromTo i = go where - go (ELam (y, sy) e) = (i + 1, shiftLam i y sy e') where (i, e') = go e + go (ELam (y, sy) e) = (i' + 1, shiftLam i' y sy e') where (i', e') = go e -- let (i', e') = go e -- y' = lamArgSymbol i' -- SHIFTLAM -- in (i' + 1, ELam (y', sy) (e' `subst1` (y, EVar y'))) @@ -89,22 +93,22 @@ class Defunc a where defunc :: a -> DF a -instance (Defunc (c a), TaggedC c a) => Defunc (GInfo c a) where +instance (Defunc (c a), TaggedC c a) => Defunc (Types.GInfo c a) where defunc fi = do - cm' <- defunc $ cm fi - ws' <- defunc $ ws fi + cm' <- defunc $ Types.cm fi + ws' <- defunc $ Types.ws fi -- NOPROP setBinds $ mconcat ((senv <$> M.elems (cm fi)) ++ (wenv <$> M.elems (ws fi))) - gLits' <- defunc $ gLits fi - dLits' <- defunc $ dLits fi - bs' <- defunc $ bs fi - ass' <- defunc $ asserts fi + gLits' <- defunc $ Types.gLits fi + dLits' <- defunc $ Types.dLits fi + bs' <- defunc $ Types.bs fi + ass' <- defunc $ Types.asserts fi -- NOPROP quals' <- defunc $ quals fi - return $ fi { cm = cm' - , ws = ws' - , gLits = gLits' - , dLits = dLits' - , bs = bs' - , asserts = ass' + return $ fi { Types.cm = cm' + , Types.ws = ws' + , Types.gLits = gLits' + , Types.dLits = dLits' + , Types.bs = bs' + , Types.asserts = ass' } instance (Defunc a) => Defunc (Triggered a) where @@ -114,12 +118,12 @@ defunc sc = do crhs' <- defunc $ _crhs sc return $ sc {_crhs = crhs'} -instance Defunc (WfC a) where - defunc wf@(WfC {}) = do +instance Defunc (WfC a) where + defunc wf@WfC{} = do let (x, t, k) = wrft wf t' <- defunc t return $ wf { wrft = (x, t', k) } - defunc wf@(GWfC {}) = do + defunc wf@GWfC{} = do let (x, t, k) = wrft wf t' <- defunc t e' <- defunc $ wexpr wf @@ -143,7 +147,7 @@ instance Defunc a => Defunc (SEnv a) where defunc = mapMSEnv defunc -instance Defunc BindEnv where +instance Defunc (BindEnv a) where defunc bs = do dfbs <- gets dfBEnv let f (i, xs) = if i `memberIBindEnv` dfbs then (i,) <$> defunc xs @@ -154,7 +158,7 @@ -- the bind does not appear in any contraint, -- thus unique binders does not perform properly -- The sort should be defunc, to ensure same sort on double binders - matchSort (x, RR s r) = ((x,) . (`RR` r)) <$> defunc s + matchSort (x, RR s r) = (x,) . (`RR` r) <$> defunc s -- Sort defunctionalization [should be done by elaboration] instance Defunc Sort where @@ -166,7 +170,7 @@ instance (Defunc a, Eq k, Hashable k) => Defunc (M.HashMap k a) where defunc m = M.fromList <$> mapM (secondM defunc) (M.toList m) -type DF = State DFST +type DF = State DFST data DFST = DFST { dfFresh :: !Int @@ -184,7 +188,7 @@ , dfEnv = env , dfBEnv = ibind , dfHO = allowHO cfg || defunction cfg - -- INVARIANT: lambads and redexes are not defunctionalized + -- INVARIANT: lambdas and redexes are not defunctionalized , dfLams = [] , dfRedex = [] , dfBinds = mempty @@ -194,7 +198,7 @@ makeInitDFState cfg si = makeDFState cfg (symbolEnv cfg si) - (mconcat ((senv <$> M.elems (cm si)) ++ (wenv <$> M.elems (ws si)))) + (mconcat ((senv <$> M.elems (Types.cm si)) ++ (wenv <$> M.elems (Types.ws si)))) -------------------------------------------------------------------------------- -- | Low level monad manipulation ---------------------------------------------- @@ -205,8 +209,3 @@ let x = intSymbol "lambda_fun_" n modify $ \s -> s {dfFresh = n + 1, dfBinds = insertSEnv x t (dfBinds s)} return x - - --- | getLams and getRedexes return the (previously seen) lambdas and redexes, --- after "closing" them by quantifying out free vars corresponding to the --- fresh binders in `dfBinds`. diff --git a/src/Language/Fixpoint/Graph/Deps.hs b/src/Language/Fixpoint/Graph/Deps.hs --- a/src/Language/Fixpoint/Graph/Deps.hs +++ b/src/Language/Fixpoint/Graph/Deps.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RecordWildCards #-} module Language.Fixpoint.Graph.Deps ( @@ -29,10 +28,6 @@ import Prelude hiding (init) import Data.Maybe (mapMaybe, fromMaybe) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Data.Tree (flatten) import Language.Fixpoint.Misc import Language.Fixpoint.Utils.Files @@ -60,9 +55,9 @@ -------------------------------------------------------------------------------- slice :: (F.TaggedC c a) => Config -> F.GInfo c a -> F.GInfo c a -------------------------------------------------------------------------------- -slice cfg fi - | noslice cfg - = fi +slice cfg fi + | noslice cfg + = fi | otherwise = fi { F.cm = cm' , F.ws = ws' } @@ -82,7 +77,7 @@ be = F.bs fi cm = F.cm fi -subcKVars :: (F.TaggedC c a) => F.BindEnv -> c a -> [F.KVar] +subcKVars :: (F.TaggedC c a) => F.BindEnv a -> c a -> [F.KVar] subcKVars be c = V.envKVars be c ++ V.rhsKVars c -------------------------------------------------------------------------------- @@ -225,22 +220,22 @@ fiKVars :: F.GInfo c a -> [F.KVar] fiKVars = M.keys . F.ws -ebindEdges :: (F.TaggedC c a) => [F.BindId] -> F.BindEnv -> c a -> [CEdge] +ebindEdges :: (F.TaggedC c a) => [F.BindId] -> F.BindEnv a -> c a -> [CEdge] ebindEdges ebs bs c = [(EBind k, Cstr i ) | k <- envEbinds xs bs c ] ++ [(Cstr i, EBind k') | k' <- rhsEbinds xs c ] where i = F.subcId c - xs = fst . flip F.lookupBindEnv bs <$> ebs + xs = fst3 . flip F.lookupBindEnv bs <$> ebs envEbinds :: (F.TaggedC c a, Foldable t) => - t F.Symbol -> F.BindEnv -> c a -> [F.Symbol] + t F.Symbol -> F.BindEnv a -> c a -> [F.Symbol] envEbinds xs be c = [ x | x <- envBinds , x `elem` xs ] where envBinds = fst <$> F.clhs be c rhsEbinds :: (Foldable t, F.TaggedC c a) => t F.Symbol -> c a -> [F.Symbol] rhsEbinds xs c = [ x | x <- F.syms (F.crhs c) , x `elem` xs ] -subcEdges :: (F.TaggedC c a) => F.BindEnv -> c a -> [CEdge] +subcEdges :: (F.TaggedC c a) => F.BindEnv a -> c a -> [CEdge] subcEdges bs c = [(KVar k, Cstr i ) | k <- V.envKVars bs c] ++ [(Cstr i, KVar k') | k' <- V.rhsKVars c ] where @@ -514,7 +509,7 @@ -- The returned map tells for each coonstraint writing a kvar -- which constraints are reading the kvar. cSuccM :: [CEdge] -> CMap [F.SubcId] -cSuccM es = (sortNub . concatMap kRdBy) <$> iWrites +cSuccM es = sortNub . concatMap kRdBy <$> iWrites where kRdBy k = M.lookupDefault [] k kReads iWrites = group [ (i, k) | (Cstr i, KVar k) <- es ] @@ -566,7 +561,7 @@ } instance PTable Stats where - ptable (Stats {..}) = DocTable [ + ptable Stats{..} = DocTable [ ("# KVars [Cut]" , pprint stNumKVCuts) , ("# KVars [NonLin]" , pprint stNumKVNonLin) , ("# KVars [All]" , pprint stNumKVTotal) @@ -594,5 +589,5 @@ bs = F.bs fi cs = M.elems (F.cm fi) -nlKVarsC :: (F.TaggedC c a) => F.BindEnv -> c a -> S.HashSet F.KVar +nlKVarsC :: (F.TaggedC c a) => F.BindEnv a -> c a -> S.HashSet F.KVar nlKVarsC bs c = S.fromList [ k | (k, n) <- V.envKVarsN bs c, n >= 2] diff --git a/src/Language/Fixpoint/Graph/Indexed.hs b/src/Language/Fixpoint/Graph/Indexed.hs --- a/src/Language/Fixpoint/Graph/Indexed.hs +++ b/src/Language/Fixpoint/Graph/Indexed.hs @@ -4,7 +4,6 @@ -- succ, pred lookup -------------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} module Language.Fixpoint.Graph.Indexed ( -- * (Abstract) Indexed Graphs diff --git a/src/Language/Fixpoint/Graph/Partition.hs b/src/Language/Fixpoint/Graph/Partition.hs --- a/src/Language/Fixpoint/Graph/Partition.hs +++ b/src/Language/Fixpoint/Graph/Partition.hs @@ -39,12 +39,9 @@ -- import Data.Function (on) import Data.Maybe (fromMaybe) import Data.Hashable -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Text.PrettyPrint.HughesPJ.Compat import Data.List (sortBy) +import Data.Function (on) -- import qualified Data.HashSet as S -- import qualified Language.Fixpoint.Solver.Solution as So @@ -59,7 +56,7 @@ data CPart c a = CPart { pws :: !(M.HashMap F.KVar (F.WfC a)) , pcm :: !(M.HashMap Integer (c a)) } - + instance Semigroup (CPart c a) where l <> r = CPart { pws = pws l <> pws r , pcm = pcm l <> pcm r @@ -68,7 +65,7 @@ instance Monoid (CPart c a) where mempty = CPart mempty mempty mappend = (<>) - + -------------------------------------------------------------------------------- -- | Multicore info ------------------------------------------------------------ -------------------------------------------------------------------------------- @@ -101,7 +98,7 @@ -- produce the maximum possible number of partitions. Or a MultiCore Info -- to control the partitioning ------------------------------------------------------------------------------ -partition' :: (F.TaggedC c a) +partition' :: (F.TaggedC c a) => Maybe MCInfo -> F.GInfo c a -> [F.GInfo c a] ------------------------------------------------------------------------------ partition' mn fi = case mn of @@ -113,8 +110,8 @@ pbc partF = partitionByConstraints partF fi -- | Partition an FInfo into a specific number of partitions of roughly equal --- amounts of work -partitionN :: MCInfo -- ^ describes thresholds and partiton amounts +-- amounts of work. +partitionN :: MCInfo -- ^ Describes thresholds and partition amounts -> F.GInfo c a -- ^ The originial FInfo -> [CPart c a] -- ^ A list of the smallest possible CParts -> [F.GInfo c a] -- ^ At most N partitions of at least thresh work @@ -134,10 +131,7 @@ sortedParts = sortBy sortPredicate cp unionFirstTwo (a:b:xs) = (a `mappend` b, xs) unionFirstTwo _ = errorstar "Partition.partitionN.unionFirstTwo called on bad arguments" - sortPredicate lhs rhs - | cpartSize lhs < cpartSize rhs = GT - | cpartSize lhs > cpartSize rhs = LT - | otherwise = EQ + sortPredicate = flip compare `on` cpartSize insertSorted a [] = [a] insertSorted a (x:xs) = if sortPredicate a x == LT then x : insertSorted a xs @@ -154,7 +148,7 @@ -- | Convert a CPart to an FInfo cpartToFinfo :: F.GInfo c a -> CPart c a -> F.GInfo c a -cpartToFinfo fi p = fi {F.ws = pws p, F.cm = pcm p} +cpartToFinfo fi p = fi {F.ws = pws p, F.cm = pcm p} -- | Convert an FInfo to a CPart finfoToCpart :: F.GInfo c a -> CPart c a diff --git a/src/Language/Fixpoint/Graph/Reducible.hs b/src/Language/Fixpoint/Graph/Reducible.hs --- a/src/Language/Fixpoint/Graph/Reducible.hs +++ b/src/Language/Fixpoint/Graph/Reducible.hs @@ -53,10 +53,12 @@ contains t x = x `elem` concatMap T.flatten t isBackEdge :: [(Node, [Node])] -> Edge -> Bool -isBackEdge t (u,v) = v `elem` xs - where - (Just xs) = lookup u t +isBackEdge t (u,v) = case lookup u t of + Just xs -> v `elem` xs + -- REVIEW: Would False work instead of error? + Nothing -> error "Unable to lookup back edge" -subcEdges' :: (F.TaggedC c a) => (F.KVar -> Node) -> F.BindEnv -> c a -> [(Node, Node)] + +subcEdges' :: (F.TaggedC c a) => (F.KVar -> Node) -> F.BindEnv a -> c a -> [(Node, Node)] subcEdges' kvI be c = [(kvI k1, kvI k2) | k1 <- V.envKVars be c , k2 <- V.kvarsExpr $ F.crhs c] diff --git a/src/Language/Fixpoint/Graph/Types.hs b/src/Language/Fixpoint/Graph/Types.hs --- a/src/Language/Fixpoint/Graph/Types.hs +++ b/src/Language/Fixpoint/Graph/Types.hs @@ -72,14 +72,14 @@ instance PPrint CVertex where pprintTidy _ (KVar k) = doubleQuotes $ pprint $ kv k - pprintTidy _ (EBind s) = doubleQuotes $ pprint $ s + pprintTidy _ (EBind s) = doubleQuotes $ pprint s pprintTidy _ (Cstr i) = text "id_" <-> pprint i pprintTidy _ (DKVar k) = pprint k <-> text "*" instance Hashable CVertex -data KVGraph = KVGraph { kvgEdges :: [(CVertex, CVertex, [CVertex])] } +newtype KVGraph = KVGraph { kvgEdges :: [(CVertex, CVertex, [CVertex])] } type CEdge = (CVertex, CVertex) type Comps a = [[a]] type KVComps = Comps CVertex diff --git a/src/Language/Fixpoint/Horn/Info.hs b/src/Language/Fixpoint/Horn/Info.hs --- a/src/Language/Fixpoint/Horn/Info.hs +++ b/src/Language/Fixpoint/Horn/Info.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} @@ -11,13 +8,13 @@ import qualified Data.HashMap.Strict as M import qualified Data.List as L import qualified Data.Tuple as Tuple -import qualified Data.Maybe as Mb import Data.Either (partitionEithers) import GHC.Generics (Generic) import qualified Language.Fixpoint.Misc as Misc import qualified Language.Fixpoint.Types as F import qualified Language.Fixpoint.Types.Config as F import qualified Language.Fixpoint.Horn.Types as H +import Data.Maybe (fromMaybe) hornFInfo :: F.Config -> H.Query a -> F.FInfo a hornFInfo cfg q = mempty @@ -37,38 +34,38 @@ (be2, ebs, cs) = hornSubCs be1 kve hCst hCst = H.qCstr q -axEnv :: F.Config -> H.Query a -> M.HashMap F.SubcId b -> F.AxiomEnv -axEnv cfg q cs = mempty +axEnv :: F.Config -> H.Query a -> M.HashMap F.SubcId b -> F.AxiomEnv +axEnv cfg q cs = mempty { F.aenvEqs = H.qEqns q , F.aenvSimpl = H.qMats q - , F.aenvExpand = if F.rewriteAxioms cfg then const True <$> cs else mempty - } + , F.aenvExpand = if F.rewriteAxioms cfg then True <$ cs else mempty + } ---------------------------------------------------------------------------------- -hornSubCs :: F.BindEnv -> KVEnv a -> H.Cstr a - -> (F.BindEnv, [F.BindId], M.HashMap F.SubcId (F.SubC a)) +hornSubCs :: F.BindEnv a -> KVEnv a -> H.Cstr a + -> (F.BindEnv a, [F.BindId], M.HashMap F.SubcId (F.SubC a)) ---------------------------------------------------------------------------------- hornSubCs be kve c = (be', ebs, M.fromList (F.addIds cs)) where - (be', ebs, cs) = goS kve F.emptyIBindEnv lhs0 be c - lhs0 = bindSortedReft kve H.dummyBind + (be', ebs, cs) = goS kve F.emptyIBindEnv be c + -- lhs0 = bindSortedReft kve H.dummyBind -- | @goS@ recursively traverses the NNF constraint to build up a list -- of the vanilla @SubC@ constraints. -goS :: KVEnv a -> F.IBindEnv -> F.SortedReft -> F.BindEnv -> H.Cstr a - -> (F.BindEnv, [F.BindId], [F.SubC a]) +goS :: KVEnv a -> F.IBindEnv -> F.BindEnv a -> H.Cstr a + -> (F.BindEnv a, [F.BindId], [F.SubC a]) -goS kve env lhs be c = (be', mEbs, subcs) +goS kve env be c = (be', mEbs, subcs) where - (be', ecs) = goS' kve env lhs be c + (be', ecs) = goS' kve env Nothing be c (mEbs, subcs) = partitionEithers ecs -goS' :: KVEnv a -> F.IBindEnv -> F.SortedReft -> F.BindEnv -> H.Cstr a - -> (F.BindEnv, [Either F.BindId (F.SubC a)]) +goS' :: KVEnv a -> F.IBindEnv -> Maybe F.SortedReft -> F.BindEnv a -> H.Cstr a + -> (F.BindEnv a, [Either F.BindId (F.SubC a)]) goS' kve env lhs be (H.Head p l) = (be, [Right subc]) where - subc = F.mkSubC env lhs rhs Nothing [] l + subc = myMkSubC env lhs rhs Nothing [] l rhs = updSortedReft kve lhs p goS' kve env lhs be (H.CAnd cs) = (be', concat subcss) @@ -77,24 +74,38 @@ goS' kve env _ be (H.All b c) = (be'', subcs) where - (be'', subcs) = goS' kve env' bSR be' c - (bId, be') = F.insertBindEnv (H.bSym b) bSR be + (be'', subcs) = goS' kve env' (Just bSR) be' c + (bId, be') = F.insertBindEnv (H.bSym b) bSR (H.bMeta b) be bSR = bindSortedReft kve b env' = F.insertsIBindEnv [bId] env goS' kve env _ be (H.Any b c) = (be'', Left bId : subcs) where - (be'', subcs) = goS' kve env' bSR be' c - (bId, be') = F.insertBindEnv (H.bSym b) bSR be + (be'', subcs) = goS' kve env' (Just bSR) be' c + (bId, be') = F.insertBindEnv (H.bSym b) bSR (H.bMeta b) be bSR = bindSortedReft kve b env' = F.insertsIBindEnv [bId] env -bindSortedReft :: KVEnv a -> H.Bind -> F.SortedReft -bindSortedReft kve (H.Bind x t p) = F.RR t (F.Reft (x, predExpr kve p)) +myMkSubC :: F.IBindEnv -> Maybe F.SortedReft -> F.SortedReft -> Maybe Integer -> F.Tag -> a -> F.SubC a +myMkSubC be lhsMb rhs x y z = F.mkSubC be lhs rhs x y z + where + lhs = fromMaybe def lhsMb + def = F.trueSortedReft (F.sr_sort rhs) -updSortedReft :: KVEnv a -> F.SortedReft -> H.Pred -> F.SortedReft -updSortedReft kve (F.RR s (F.Reft (v, _))) p = F.RR s (F.Reft (v, predExpr kve p)) +bindSortedReft :: KVEnv a -> H.Bind a -> F.SortedReft +bindSortedReft kve (H.Bind x t p _) = F.RR t (F.Reft (x, predExpr kve p)) +updSortedReft :: KVEnv a -> Maybe F.SortedReft -> H.Pred -> F.SortedReft +updSortedReft kve lhs p = F.RR s (F.Reft (v, predExpr kve p)) + where + (s, v) = case lhs of + Just (F.RR ss (F.Reft (vv, _))) -> (ss, vv) + Nothing -> (F.intSort, F.dummySymbol) + +-- dummyBind :: a -> Bind a +-- dummyBind = Bind F.dummySymbol F.intSort (PAnd []) + + predExpr :: KVEnv a -> H.Pred -> F.Expr predExpr kve = go where @@ -106,11 +117,11 @@ kvApp kve k ys = F.PKVar (F.KV k) su where su = F.mkSubst (zip params (F.eVar <$> ys)) - params = Mb.fromMaybe err1 $ kvParams <$> M.lookup k kve + params = maybe err1 kvParams (M.lookup k kve) err1 = F.panic ("Unknown Horn variable: " ++ F.showpp k) ---------------------------------------------------------------------------------- -hornWfs :: F.BindEnv -> [H.Var a] -> (F.BindEnv, KVEnv a) +hornWfs :: F.BindEnv a -> [H.Var a] -> (F.BindEnv a, KVEnv a) ---------------------------------------------------------------------------------- hornWfs be vars = (be', kve) where @@ -118,8 +129,8 @@ (be', is) = L.mapAccumL kvInfo be vars kname = H.hvName . kvVar -kvInfo :: F.BindEnv -> H.Var a -> (F.BindEnv, KVInfo a) -kvInfo be k = (be', KVInfo k (fst <$> xts) wfc) +kvInfo :: F.BindEnv a -> H.Var a -> (F.BindEnv a, KVInfo a) +kvInfo be k = (be', KVInfo k (Misc.fst3 <$> xts) wfc) where -- make the WfC wfc = F.WfC wenv wrft (H.hvMeta k) @@ -127,12 +138,13 @@ wrft = (x, t, F.KV (H.hvName k)) -- add the binders (be', ids) = L.mapAccumL insertBE be xts' - ((x,t), xts') = Misc.safeUncons "Horn var with no args" xts + ((x,t,_), xts') = Misc.safeUncons "Horn var with no args" xts -- make the parameters - xts = [ (hvarArg k i, t) | (t, i) <- zip (H.hvArgs k) [0..] ] + xts = [ (hvarArg k i, t', a) | (t', i) <- zip (H.hvArgs k) [0..] ] + a = H.hvMeta k -insertBE :: F.BindEnv -> (F.Symbol, F.Sort) -> (F.BindEnv, F.BindId) -insertBE be (x, t) = Tuple.swap $ F.insertBindEnv x (F.trueSortedReft t) be +insertBE :: F.BindEnv a -> (F.Symbol, F.Sort, a) -> (F.BindEnv a, F.BindId) +insertBE be (x, t, a) = Tuple.swap $ F.insertBindEnv x (F.trueSortedReft t) a be ---------------------------------------------------------------------------------- -- | Data types and helpers for manipulating information about KVars diff --git a/src/Language/Fixpoint/Horn/Parse.hs b/src/Language/Fixpoint/Horn/Parse.hs --- a/src/Language/Fixpoint/Horn/Parse.hs +++ b/src/Language/Fixpoint/Horn/Parse.hs @@ -30,8 +30,8 @@ , H.qCstr = H.CAnd [ c | HCstr c <- things ] , H.qCon = M.fromList [ (x,t) | HCon x t <- things ] , H.qDis = M.fromList [ (x,t) | HDis x t <- things ] - , H.qEqns = [ e | HDef e <- things ] - , H.qMats = [ m | HMat m <- things ] + , H.qEqns = [ e | HDef e <- things ] + , H.qMats = [ m | HMat m <- things ] , H.qData = [ dd | HDat dd <- things ] } @@ -46,9 +46,9 @@ -- for uninterpred functions and ADT constructors | HCon F.Symbol F.Sort | HDis F.Symbol F.Sort - | HDef F.Equation + | HDef F.Equation | HMat F.Rewrite - | HDat F.DataDecl + | HDat !F.DataDecl | HOpt !String deriving (Functor) @@ -70,17 +70,16 @@ ------------------------------------------------------------------------------- hCstrP = parens body where - body = H.CAnd <$> (reserved "and" *> some hCstrP) + body = H.CAnd <$> (reserved "and" *> many hCstrP) <|> H.All <$> (reserved "forall" *> hBindP) <*> hCstrP <|> H.Any <$> (reserved "exists" *> hBindP) <*> hCstrP <|> H.Head <$> (reserved "tag" *> hPredP) <*> (H.Tag <$> stringLiteral) <|> H.Head <$> hPredP <*> pure H.NoTag -hBindP :: Parser H.Bind +hBindP :: Parser (H.Bind H.Tag) hBindP = parens $ do (x, t) <- symSortP - p <- hPredP - return $ H.Bind x t p + H.Bind x t <$> hPredP <*> pure H.NoTag ------------------------------------------------------------------------------- hPredP :: Parser H.Pred @@ -113,7 +112,7 @@ ------------------------------------------------------------------------------- hVarP :: Parser (H.Var H.Tag) -hVarP = H.HVar <$> kvSymP <*> parens (some (parens sortP)) <*> pure H.NoTag +hVarP = H.HVar <$> kvSymP <*> parens (some (parens sortP)) <*> pure H.NoTag ------------------------------------------------------------------------------- -- | Helpers @@ -121,5 +120,3 @@ symSortP :: Parser (F.Symbol, F.Sort) symSortP = parens ((,) <$> symbolP <*> sortP) - - diff --git a/src/Language/Fixpoint/Horn/Solve.hs b/src/Language/Fixpoint/Horn/Solve.hs --- a/src/Language/Fixpoint/Horn/Solve.hs +++ b/src/Language/Fixpoint/Horn/Solve.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + ------------------------------------------------------------------------------- -- | This module defines a function to solve NNF constraints, -- by reducing them to the standard FInfo. @@ -29,12 +31,12 @@ ---------------------------------------------------------------------------------- solveHorn cfg = do (q, opts) <- parseQuery cfg - + -- If you want to set --eliminate=none, you better make it a pragma cfg <- if F.eliminate cfg == F.None then pure (cfg { F.eliminate = F.Some }) else pure cfg - + cfg <- F.withPragmas cfg opts when (F.save cfg) (saveHornQuery cfg q) @@ -43,7 +45,7 @@ Solver.resultExitCode cfg r parseQuery :: F.Config -> IO (H.Query H.Tag, [String]) -parseQuery cfg +parseQuery cfg | F.stdin cfg = Parse.parseFromStdIn H.hornP | otherwise = Parse.parseFromFile H.hornP (F.srcFile cfg) @@ -77,4 +79,3 @@ whenLoud $ putStrLn $ F.showpp c q <- eliminate cfg ({- void $ -} q { H.qCstr = c }) Solver.solve cfg (hornFInfo cfg q) - diff --git a/src/Language/Fixpoint/Horn/Transformations.hs b/src/Language/Fixpoint/Horn/Transformations.hs --- a/src/Language/Fixpoint/Horn/Transformations.hs +++ b/src/Language/Fixpoint/Horn/Transformations.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Horn.Transformations ( uniq , flatten @@ -22,7 +24,7 @@ import qualified Data.HashMap.Strict as M import Data.String (IsString (..)) import Data.Either (partitionEithers, rights) -import Data.List (nub) +import Data.List (nub, foldl') import qualified Data.Set as S import qualified Data.HashSet as HS import qualified Data.Graph as DG @@ -30,7 +32,7 @@ import Data.Maybe (catMaybes, mapMaybe, fromMaybe) import Language.Fixpoint.Types.Visitor as V import System.Console.CmdArgs.Verbosity -import Data.Bifunctor (second) +import Data.Bifunctor (first, second) import System.IO (hFlush, stdout) -- import qualified Debug.Trace as DBG @@ -50,13 +52,15 @@ printPiSols :: (F.PPrint a1, F.PPrint a2, F.PPrint a3) => M.HashMap a1 ((a4, a2), a3) -> IO () printPiSols piSols = - sequence_ $ ((\(piVar, ((_, args), cstr)) -> do + mapM_ + (\(piVar, ((_, args), cstr)) -> do putStr $ F.showpp piVar putStr " := " putStrLn $ F.showpp args putStrLn $ F.showpp cstr putStr "\n" - hFlush stdout) <$> M.toList piSols) + hFlush stdout) + (M.toList piSols) --------------- -- type Sol a = M.HashMap F.Symbol (Either (Either [[Bind]] (Cstr a)) F.Expr) @@ -85,9 +89,13 @@ whenLoud $ putStrLn $ F.showpp poked whenLoud $ putStrLn "Skolemized + split:" - let (Just _horn, Just _side) = split poked + let (_horn, _side) = case split poked of + (Just h, Just s) -> (h, s) + _ -> error "Couldn't split poked in solveEbs" + let horn = flatten . pruneTauts $ _horn let side = flatten . pruneTauts $ _side + whenLoud $ putStrLn $ F.showpp (horn, side) -- collect predicate variables @@ -122,7 +130,7 @@ let solvedSide = substPiSols solvedPiCstrs side' whenLoud $ putStrLn $ F.showpp solvedSide - pure $ (Query qs vs (CAnd [solvedHorn, solvedSide]) cons dist eqns mats dds) + pure (Query qs vs (CAnd [solvedHorn, solvedSide]) cons dist eqns mats dds) -- | Collects the defining constraint for π -- that is, given `∀ Γ.∀ n.π => c`, returns `((π, n:Γ), c)` @@ -135,7 +143,7 @@ go :: Cstr a -> ([F.Symbol], [[F.Symbol]], Maybe (Cstr a)) go (CAnd cs) = (\(as, bs, cs) -> (concat as, concat bs, cAndMaybes cs)) $ unzip3 $ go <$> cs - go (All b@(Bind n _ (Var k' xs)) c') + go (All b@(Bind n _ (Var k' xs) _) c') | k == k' = ([n], [S.toList $ S.fromList xs `S.difference` S.singleton n], Just c') | otherwise = map3 (fmap (All b)) (go c') go (All b c') = map3 (fmap (All b)) (go c') @@ -159,7 +167,7 @@ -- TODO: rewrite to use CC solPi :: S.Set F.Symbol -> F.Symbol -> F.Symbol -> S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> Cstr a -> Pred -solPi measures basePi n args piSols c = trace ("\n\nsolPi: " <> F.showpp basePi <> "\n\n" <> F.showpp n <> "\n" <> F.showpp (S.toList args) <> "\n" <> F.showpp ((\(a, _, c) -> (a, c)) <$> edges) <> "\n" <> F.showpp (sols n) <> "\n" <> F.showpp rewritten <> "\n" <> F.showpp c <> "\n\n") $ PAnd $ rewritten +solPi measures basePi n args piSols c = trace ("\n\nsolPi: " <> F.showpp basePi <> "\n\n" <> F.showpp n <> "\n" <> F.showpp (S.toList args) <> "\n" <> F.showpp ((\(a, _, c) -> (a, c)) <$> edges) <> "\n" <> F.showpp (sols n) <> "\n" <> F.showpp rewritten <> "\n" <> F.showpp c <> "\n\n") $ PAnd rewritten where rewritten = rewriteWithEqualities measures n args equalities equalities = (nub . fst) $ go (S.singleton basePi) c @@ -171,14 +179,14 @@ go :: S.Set F.Symbol -> Cstr a -> ([(F.Symbol, F.Expr)], S.Set F.Symbol) go visited (Head p _) = (collectEqualities p, visited) - go visited (CAnd cs) = foldl (\(eqs, visited) c -> let (eqs', visited') = go visited c in (eqs' <> eqs, visited')) (mempty, visited) cs - go visited (All (Bind _ _ (Var pi _)) c) + go visited (CAnd cs) = foldl' (\(eqs, visited) c -> let (eqs', visited') = go visited c in (eqs' <> eqs, visited')) (mempty, visited) cs + go visited (All (Bind _ _ (Var pi _) _) c) | S.member pi visited = go visited c | otherwise = let (_, defC) = (piSols M.! pi) (eqs', newVisited) = go (S.insert pi visited) defC (eqs'', newVisited') = go newVisited c in (eqs' <> eqs'', newVisited') - go visited (All (Bind _ _ p) c) = let (eqs, visited') = go visited c in + go visited (All (Bind _ _ p _) c) = let (eqs, visited') = go visited c in (eqs <> collectEqualities p, visited') go _ Any{} = error "exists should not be present in piSols" @@ -233,11 +241,11 @@ where go _ (Head c l) = Head c l go xs (CAnd c) = CAnd (go xs <$> c) - go xs (All b c2) = All b $ go ((bSym b):xs) c2 - go xs (Any b@(Bind x t p) c2) = CAnd [All b' $ CAnd [Head p l, go (x:xs) c2], Any b (Head pi l)] + go xs (All b c2) = All b $ go (bSym b : xs) c2 + go xs (Any b@(Bind x t p ann) c2) = CAnd [All b' $ CAnd [Head p l, go (x:xs) c2], Any b (Head pi l)] -- TODO: actually use the renamer? where - b' = Bind x t pi + b' = Bind x t pi ann pi = piVar x xs l = cLabel c2 @@ -378,14 +386,17 @@ elimPis [] cc = cc elimPis (n:ns) (horn, side) = elimPis ns (apply horn, apply side) -- TODO: handle this error? - where Just nSol = defs n horn + where nSol = case defs n horn of + Just nSol -> nSol + Nothing -> error "Unexpected nothing elimPis" + apply = applyPi (piSym n) nSol -- TODO: PAnd may be a problem applyPi :: F.Symbol -> Cstr a -> Cstr a -> Cstr a -applyPi k defs (All (Bind x t (Var k' _xs)) c) +applyPi k defs (All (Bind x t (Var k' _xs) ann) c) | k == k' - = All (Bind x t (Reft $ cstrToExpr defs)) c + = All (Bind x t (Reft $ cstrToExpr defs) ann) c applyPi k bp (CAnd cs) = CAnd $ applyPi k bp <$> cs applyPi k bp (All b c) @@ -453,7 +464,7 @@ defs :: F.Symbol -> Cstr a -> Maybe (Cstr a) defs x (CAnd cs) = andMaybes $ defs x <$> cs -defs x (All (Bind x' _ _) c) +defs x (All (Bind x' _ _ _) c) | x' == x = pure c defs x (All _ c) = defs x c @@ -463,8 +474,8 @@ cstrToExpr :: Cstr a -> F.Expr cstrToExpr (Head p _) = predToExpr p cstrToExpr (CAnd cs) = F.PAnd $ cstrToExpr <$> cs -cstrToExpr (All (Bind x t p) c) = F.PAll [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c -cstrToExpr (Any (Bind x t p) c) = F.PExist [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c +cstrToExpr (All (Bind x t p _) c) = F.PAll [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c +cstrToExpr (Any (Bind x t p _) c) = F.PExist [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c predToExpr :: Pred -> F.Expr predToExpr (Reft e) = e @@ -555,8 +566,8 @@ instance V.Visitable (Cstr a) where visit v c (CAnd cs) = CAnd <$> mapM (visit v c) cs visit v c (Head p a) = Head <$> visit v c p <*> pure a - visit v ctx (All (Bind x t p) c) = All <$> (Bind x t <$> visit v ctx p) <*> visit v ctx c - visit v ctx (Any (Bind x t p) c) = All <$> (Bind x t <$> visit v ctx p) <*> visit v ctx c + visit v ctx (All (Bind x t p l) c) = All <$> (Bind x t <$> visit v ctx p <*> pure l) <*> visit v ctx c + visit v ctx (Any (Bind x t p l) c) = All <$> (Bind x t <$> visit v ctx p <*> pure l) <*> visit v ctx c ------------------------------------------------------------------------------ -- | Quantifier elimination for use with implicit solver @@ -621,7 +632,7 @@ nResult = (n, makeWellFormed 15 $ sols n) argResults = map (\arg -> (arg, makeWellFormed 15 $ sols arg)) (S.toList args) - preds = (mconcat $ (\(x, es) -> mconcat $ mkEquality x <$> es) <$> (nResult:argResults)) + preds = mconcat $ (\(x, es) -> mconcat $ mkEquality x <$> es) <$> (nResult:argResults) mkEquality x e = [Reft (F.PAtom F.Eq (F.EVar x) e)] @@ -630,10 +641,10 @@ Nothing -> [] Just vertex -> nub $ filter (/= F.EVar x) $ mconcat [es | ((_, es), _, _) <- vf <$> DG.reachable eGraph vertex] - argsAndPrims = args `S.union` (S.fromList $ map fst $ F.toListSEnv $ F.theorySymbols []) `S.union`measures + argsAndPrims = args `S.union` S.fromList (map fst $ F.toListSEnv $ F.theorySymbols []) `S.union`measures isWellFormed :: F.Expr -> Bool - isWellFormed e = (S.fromList $ F.syms e) `S.isSubsetOf` argsAndPrims + isWellFormed e = S.fromList (F.syms e) `S.isSubsetOf` argsAndPrims makeWellFormed :: Int -> [F.Expr] -> [F.Expr] makeWellFormed 0 es = filter isWellFormed es -- We solved it. Maybe. @@ -641,7 +652,7 @@ where go e = if isWellFormed e then [e] else rewrite rewrites [e] where - needSolving = (S.fromList $ F.syms e) `S.difference` argsAndPrims + needSolving = S.fromList (F.syms e) `S.difference` argsAndPrims rewrites = (\x -> (x, filter (/= F.EVar x) $ sols x)) <$> S.toList needSolving rewrite [] es = es rewrite ((x, rewrites):rewrites') es = rewrite rewrites' $ [F.subst (F.mkSubst [(x, e')]) e | e' <- rewrites, e <- es] @@ -679,10 +690,10 @@ substPiSols :: M.HashMap F.Symbol Pred -> Cstr a -> Cstr a substPiSols _ c@Head{} = c substPiSols piSols (CAnd cs) = CAnd $ substPiSols piSols <$> cs -substPiSols piSols (All (Bind x t p) c) - | Var k _ <- p = All (Bind x t $ M.lookupDefault p k piSols) (substPiSols piSols c) - | otherwise = All (Bind x t p) (substPiSols piSols c) -substPiSols piSols (Any (Bind n _ p) c) +substPiSols piSols (All (Bind x t p l) c) + | Var k _ <- p = All (Bind x t (M.lookupDefault p k piSols) l) (substPiSols piSols c) + | otherwise = All (Bind x t p l) (substPiSols piSols c) +substPiSols piSols (Any (Bind n _ p _) c) | Head (Var pi _) label <- c, Just sol <- M.lookup pi piSols = case findSol n sol of Just e -> Head (flatten $ PAnd $ (\pred -> F.subst1 pred (n, e)) <$> [p, sol]) label @@ -712,14 +723,14 @@ uniq c = evalState (uniq' c) M.empty uniq' :: Cstr a -> State RenameMap (Cstr a) -uniq' (Head c a) = Head <$> gets (rename c) <*> pure a +uniq' (Head c a) = gets (Head . rename c) <*> pure a uniq' (CAnd c) = CAnd <$> mapM uniq' c -uniq' (All b@(Bind x _ _) c2) = do +uniq' (All b@(Bind x _ _ _) c2) = do b' <- uBind b c2' <- uniq' c2 modify $ popName x pure $ All b' c2' -uniq' (Any b@(Bind x _ _) c2) = do +uniq' (Any b@(Bind x _ _ _) c2) = do b' <- uBind b c2' <- uniq' c2 modify $ popName x @@ -732,12 +743,11 @@ pushName Nothing = Just (0, [0]) pushName (Just (i, is)) = Just (i + 1, (i + 1):is) -uBind :: Bind -> State RenameMap Bind -uBind (Bind x t p) = do +uBind :: Bind a -> State RenameMap (Bind a) +uBind (Bind x t p l) = do x' <- uVariable x - -- nmap <- get p' <- gets (rename p) - pure $ Bind x' t p' + pure $ Bind x' t p' l uVariable :: IsString a => F.Symbol -> State RenameMap a uVariable x = do @@ -773,7 +783,7 @@ ------------------------------------------------------------------------------ elim c = if S.null $ boundKvars res then res else error "called elim on cyclic constraint" where - res = S.foldl elim1 c (boundKvars c) + res = S.foldl' elim1 c (boundKvars c) elim1 :: Cstr a -> F.Symbol -> Cstr a -- Find a `sol1` solution to a kvar `k`, and then subsitute in the solution for @@ -795,8 +805,8 @@ go c@(Head (Var k' _) _) | k' == k = Right c go (Head _ l) = Left l - go c@(All (Bind _ _ p) c') = - if k `S.member` (pKVars p) then Right c else go c' + go c@(All (Bind _ _ p _) c') = + if k `S.member` pKVars p then Right c else go c' go Any{} = error "any should not appear after poke" -- if kvar doesn't appear, then just return the left @@ -829,9 +839,9 @@ -- - `bss` is a Hyp, that tells us the solution to a Var, that is, -- a collection of cubes that we'll want to disjunct -sol1 :: F.Symbol -> Cstr a -> [([Bind], [F.Expr])] +sol1 :: F.Symbol -> Cstr a -> [([Bind a], [F.Expr])] sol1 k (CAnd cs) = sol1 k =<< cs -sol1 k (All b c) = (\(bs, eqs) -> (b:bs, eqs)) <$> sol1 k c +sol1 k (All b c) = first (b :) <$> sol1 k c sol1 k (Head (Var k' ys) _) | k == k' = [([], zipWith (F.PAtom F.Eq) (F.EVar <$> xs) (F.EVar <$> ys))] where xs = zipWith const (kargs k) ys @@ -839,37 +849,37 @@ sol1 _ (Any _ _) = error "ebinds don't work with old elim" kargs :: F.Symbol -> [F.Symbol] -kargs k = fromString . (("κarg$" ++ F.symbolString k ++ "#") ++) . show <$> [1..] +kargs k = fromString . (("κarg$" ++ F.symbolString k ++ "#") ++) . show <$> [1 :: Integer ..] -- | -- >>> LET c = doParse' hCstrP "" "(forall ((z Int) ($k0 z)) ((z = x)))" -- >>> doelim "k0" [[Bind "v" F.boolSort (Reft $ F.EVar "v"), Bind "_" F.boolSort (Reft $ F.EVar "donkey")]] c -- (forall ((v bool) (v)) (forall ((z int) (donkey)) ((z == x)))) -doelim :: F.Symbol -> [([Bind], [F.Expr])] -> Cstr a -> Cstr a +doelim :: F.Symbol -> [([Bind a], [F.Expr])] -> Cstr a -> Cstr a doelim k bss (CAnd cs) = CAnd $ doelim k bss <$> cs -doelim k bss (All (Bind x t p) c) = +doelim k bss (All (Bind x t p l) c) = case findKVarInGuard k p of - Right _ -> All (Bind x t p) (doelim k bss c) - Left (kvars, preds) -> demorgan x t kvars preds (doelim k bss c) bss + Right _ -> All (Bind x t p l) (doelim k bss c) + Left (kvars, preds) -> demorgan x t l kvars preds (doelim k bss c) bss where - demorgan :: F.Symbol -> F.Sort -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind], [F.Expr])] -> Cstr a - demorgan x t kvars preds c bss = mkAnd $ cubeSol <$> bss - where su = F.Su $ M.fromList $ concat $ map (\(k, xs) -> zip (kargs k) (F.EVar <$> xs)) kvars + demorgan :: F.Symbol -> F.Sort -> a -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind a], [F.Expr])] -> Cstr a + demorgan x t ann kvars preds c bss = mkAnd $ cubeSol <$> bss + where su = F.Su $ M.fromList $ concatMap (\(k, xs) -> zip (kargs k) (F.EVar <$> xs)) kvars mkAnd [c] = c mkAnd cs = CAnd cs - cubeSol ((b:bs), eqs) = All b $ cubeSol (bs, eqs) - cubeSol ([], eqs) = All (Bind x t (PAnd $ (Reft <$> F.subst su eqs) ++ (F.subst su <$> preds))) c + cubeSol (b:bs, eqs) = All b $ cubeSol (bs, eqs) + cubeSol ([], eqs) = All (Bind x t (PAnd $ (Reft <$> F.subst su eqs) ++ (F.subst su <$> preds)) ann) c doelim k _ (Head (Var k' _) a) | k == k' = Head (Reft F.PTrue) a doelim _ _ (Head p a) = Head p a -doelim k bss (Any (Bind x t p) c) = +doelim k bss (Any (Bind x t p l) c) = case findKVarInGuard k p of - Right _ -> Any (Bind x t p) (doelim k bss c) - Left (_, rights) -> Any (Bind x t (PAnd rights)) (doelim k bss c) -- TODO: for now we set the kvar to true. not sure if this is correct + Right _ -> Any (Bind x t p l) (doelim k bss c) + Left (_, rights) -> Any (Bind x t (PAnd rights) l) (doelim k bss c) -- TODO: for now we set the kvar to true. not sure if this is correct -- If k is in the guard then returns a Left list of that k and the remaining preds in the guard -- If k is not in the guard returns a Right of the pred @@ -877,11 +887,11 @@ findKVarInGuard k (PAnd ps) = if null lefts then Right (PAnd ps) -- kvar not found - else Left $ (newLefts, newRights) + else Left (newLefts, newRights) where findResults = findKVarInGuard k <$> ps (lefts, rights) = partitionEithers findResults - newLefts = concat $ map fst lefts - newRights = concat (snd <$> lefts) ++ rights + newLefts = concatMap fst lefts + newRights = concatMap snd lefts ++ rights findKVarInGuard k p@(Var k' xs) | k == k' = Left ([(k', xs)], []) | otherwise = Right p @@ -905,8 +915,8 @@ boundKvars :: Cstr a -> S.Set F.Symbol boundKvars (Head p _) = pKVars p boundKvars (CAnd c) = mconcat $ boundKvars <$> c -boundKvars (All (Bind _ _ p) c) = pKVars p <> boundKvars c -boundKvars (Any (Bind _ _ p) c) = pKVars p <> boundKvars c +boundKvars (All (Bind _ _ p _) c) = pKVars p <> boundKvars c +boundKvars (Any (Bind _ _ p _) c) = pKVars p <> boundKvars c pKVars :: Pred -> S.Set F.Symbol pKVars (Var k _) = S.singleton k @@ -924,14 +934,14 @@ calculateCuts cfg (Query qs vs _ cons dist eqns mats dds) nnf = convert $ FG.depCuts deps where (_, deps) = elimVars cfg (hornFInfo cfg $ Query qs vs nnf cons dist eqns mats dds) - convert hashset = S.fromList $ F.kv <$> (HS.toList hashset) + convert hashset = S.fromList $ F.kv <$> HS.toList hashset forgetPiVars :: S.Set F.Symbol -> Cstr a -> Cstr a forgetPiVars _ c@Head{} = c forgetPiVars pis (CAnd cs) = CAnd $ forgetPiVars pis <$> cs -forgetPiVars pis (All (Bind x t p) c) - | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd [])) $ forgetPiVars pis c - | otherwise = All (Bind x t p) $ forgetPiVars pis c +forgetPiVars pis (All (Bind x t p l) c) + | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd []) l) $ forgetPiVars pis c + | otherwise = All (Bind x t p l) $ forgetPiVars pis c forgetPiVars _ Any{} = error "shouldn't be present" ----------------------------------------------------------------------------------- @@ -964,8 +974,8 @@ [c] -> c cs -> CAnd cs flatten (Head p a) = Head (flatten p) a - flatten (All (Bind x t p) c) = All (Bind x t (flatten p)) (flatten c) - flatten (Any (Bind x t p) c) = Any (Bind x t (flatten p)) (flatten c) + flatten (All (Bind x t p l) c) = All (Bind x t (flatten p) l) (flatten c) + flatten (Any (Bind x t p l) c) = Any (Bind x t (flatten p) l) (flatten c) instance Flatten [Cstr a] where flatten (CAnd cs : xs) = flatten cs ++ flatten xs @@ -1010,10 +1020,10 @@ hornify (Head (PAnd ps) a) = CAnd (flip Head a <$> ps') where ps' = let (ks, qs) = split [] [] (flatten ps) in PAnd qs : ks - split kacc pacc ((Var x xs):qs) = split ((Var x xs):kacc) pacc qs + split kacc pacc ((Var x xs):qs) = split (Var x xs : kacc) pacc qs split kacc pacc (q:qs) = split kacc (q:pacc) qs split kacc pacc [] = (kacc, pacc) -hornify (Head (Reft r) a) = CAnd (flip Head a <$> ((Reft $ F.PAnd ps):(Reft <$> ks))) +hornify (Head (Reft r) a) = CAnd (flip Head a <$> (Reft (F.PAnd ps):(Reft <$> ks))) where (ks, ps) = split [] [] $ F.splitPAnd r split kacc pacc (r@F.PKVar{}:rs) = split (r:kacc) pacc rs split kacc pacc (r:rs) = split kacc (r:pacc) rs @@ -1028,7 +1038,7 @@ where go _ c@Head{} = c go xs (CAnd cs) = CAnd $ go xs <$> cs - go xs (All b@(Bind x _ _) c) = if x `S.member` xs then go xs c else All b $ go (S.insert x xs) c + go xs (All b@(Bind x _ _ _) c) = if x `S.member` xs then go xs c else All b $ go (S.insert x xs) c go xs (Any b c) = Any b $ go xs c pruneTauts :: Cstr a -> Cstr a diff --git a/src/Language/Fixpoint/Horn/Types.hs b/src/Language/Fixpoint/Horn/Types.hs --- a/src/Language/Fixpoint/Horn/Types.hs +++ b/src/Language/Fixpoint/Horn/Types.hs @@ -1,40 +1,39 @@ ------------------------------------------------------------------------------- --- | This module formalizes the key datatypes needed to represent Horn NNF +-- | This module formalizes the key datatypes needed to represent Horn NNF -- constraints as described in "Local Refinement Typing", ICFP 2017 ------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} -module Language.Fixpoint.Horn.Types +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Language.Fixpoint.Horn.Types ( -- * Horn Constraints and their components Query (..) , Cstr (..) , Pred (..) , Bind (..) - , Var (..) + , Var (..) -- * Raw Query , Tag (..) , TagVar - , TagQuery + , TagQuery -- * accessing constraint labels , cLabel - -- * invariants (refinements) on constraints - , okCstr - , dummyBind + -- * invariants (refinements) on constraints + , okCstr - -- * extract qualifiers + -- * extract qualifiers , quals - ) - where + ) + where import Data.Generics (Data) import Data.Typeable (Typeable) @@ -50,7 +49,7 @@ import Data.Aeson ------------------------------------------------------------------------------- --- | @HVar@ is a Horn variable +-- | @HVar@ is a Horn variable ------------------------------------------------------------------------------- data Var a = HVar { hvName :: !F.Symbol -- ^ name of the variable $k1, $k2 etc. @@ -60,19 +59,19 @@ deriving (Eq, Ord, Data, Typeable, Generic, Functor) ------------------------------------------------------------------------------- --- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints +-- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints ------------------------------------------------------------------------------- -data Pred - = Reft !F.Expr -- ^ r - | Var !F.Symbol ![F.Symbol] -- ^ $k(y1..yn) - | PAnd ![Pred] -- ^ p1 /\ .../\ pn +data Pred + = Reft !F.Expr -- ^ r + | Var !F.Symbol ![F.Symbol] -- ^ $k(y1..yn) + | PAnd ![Pred] -- ^ p1 /\ .../\ pn deriving (Data, Typeable, Generic, Eq) instance Semigroup Pred where p1 <> p2 = PAnd [p1, p2] -instance Monoid Pred where +instance Monoid Pred where mempty = Reft mempty instance F.Subable Pred where @@ -97,21 +96,21 @@ subst1 (Var k xs) su = Var k [F.subst1 x su | x <- xs] ------------------------------------------------------------------------------- -quals :: Cstr a -> [F.Qualifier] +quals :: Cstr a -> [F.Qualifier] ------------------------------------------------------------------------------- -quals = F.tracepp "horn.quals" . cstrQuals F.emptySEnv F.vv_ +quals = F.tracepp "horn.quals" . cstrQuals F.emptySEnv F.vv_ -cstrQuals :: F.SEnv F.Sort -> F.Symbol -> Cstr a -> [F.Qualifier] -cstrQuals = go +cstrQuals :: F.SEnv F.Sort -> F.Symbol -> Cstr a -> [F.Qualifier] +cstrQuals = go where go env v (Head p _) = predQuals env v p go env v (CAnd cs) = concatMap (go env v) cs - go env _ (All b c) = bindQuals env b c + go env _ (All b c) = bindQuals env b c go env _ (Any b c) = bindQuals env b c -bindQuals :: F.SEnv F.Sort -> Bind -> Cstr a -> [F.Qualifier] -bindQuals env b c = predQuals env' bx (bPred b) ++ cstrQuals env' bx c - where +bindQuals :: F.SEnv F.Sort -> Bind a -> Cstr a -> [F.Qualifier] +bindQuals env b c = predQuals env' bx (bPred b) ++ cstrQuals env' bx c + where env' = F.insertSEnv bx bt env bx = bSym b bt = bSort b @@ -119,24 +118,24 @@ predQuals :: F.SEnv F.Sort -> F.Symbol -> Pred -> [F.Qualifier] predQuals env v (Reft p) = exprQuals env v p predQuals env v (PAnd ps) = concatMap (predQuals env v) ps -predQuals _ _ _ = [] +predQuals _ _ _ = [] exprQuals :: F.SEnv F.Sort -> F.Symbol -> F.Expr -> [F.Qualifier] exprQuals env v e = mkQual env v <$> F.conjuncts e mkQual :: F.SEnv F.Sort -> F.Symbol -> F.Expr -> F.Qualifier mkQual env v p = case envSort env <$> (v:xs) of - (_,so):xts -> F.mkQ "Auto" ((v, so) : xts) p junk + (_,so):xts -> F.mkQ "Auto" ((v, so) : xts) p junk _ -> F.panic "impossible" where xs = L.delete v $ Misc.hashNub (F.syms p) - junk = F.dummyPos "mkQual" + junk = F.dummyPos "mkQual" envSort :: F.SEnv F.Sort -> F.Symbol -> (F.Symbol, F.Sort) envSort env x = case F.lookupSEnv x env of - Just t -> (x, t) + Just t -> (x, t) _ -> F.panic $ "unbound symbol in scrape: " ++ F.showpp x -{- +{- | Just _ <- lookupSEnv x lEnv = Nothing | otherwise = Just (x, ai) where @@ -146,31 +145,31 @@ -------------------------------------------------------------------------------- --- | @Cst@ is an NNF Horn Constraint. +-- | @Cst@ is an NNF Horn Constraint. ------------------------------------------------------------------------------- -- Note that a @Bind@ is a simplified @F.SortedReft@ ... -data Bind = Bind - { bSym :: !F.Symbol - , bSort :: !F.Sort - , bPred :: !Pred +data Bind a = Bind + { bSym :: !F.Symbol + , bSort :: !F.Sort + , bPred :: !Pred + , bMeta :: !a } - deriving (Data, Typeable, Generic, Eq) - -instance F.Subable Bind where - syms = undefined - substa = undefined - substf = undefined - subst su (Bind x t p) = (Bind x t (F.subst su p)) + deriving (Data, Typeable, Generic, Functor, Eq) -dummyBind :: Bind -dummyBind = Bind F.dummySymbol F.intSort (PAnd []) +instance F.Subable (Bind a) where + syms (Bind x _ p _) = x : F.syms p + substa f (Bind v t p a) = Bind (f v) t (F.substa f p) a + substf f (Bind v t p a) = Bind v t (F.substf (F.substfExcept f [v]) p) a + -- subst su (Bind x t p) = (Bind x t (F.subst su p)) + subst su (Bind v t p a) = Bind v t (F.subst (F.substExcept su [v]) p) a + subst1 (Bind v t p a) su = Bind v t (F.subst1Except [v] p su) a -- Can we enforce the invariant that CAnd has len > 1? data Cstr a - = Head !Pred a -- ^ p - | CAnd ![(Cstr a)] -- ^ c1 /\ ... /\ cn - | All !Bind !(Cstr a) -- ^ \all x:t. p => c - | Any !Bind !(Cstr a) -- ^ \exi x:t. p /\ c or is it \exi x:t. p => c? + = Head !Pred !a -- ^ p + | CAnd ![Cstr a] -- ^ c1 /\ ... /\ cn + | All !(Bind a) !(Cstr a) -- ^ \all x:t. p => c + | Any !(Bind a) !(Cstr a) -- ^ \exi x:t. p /\ c or is it \exi x:t. p => c? deriving (Data, Typeable, Generic, Functor, Eq) cLabel :: Cstr a -> a @@ -184,24 +183,26 @@ go (Any _ c) = go c -- We want all valid constraints to start with a binding at the top -okCstr :: Cstr a -> Bool -okCstr (All {}) = True -okCstr (Any {}) = True -okCstr _ = False +okCstr :: Cstr a -> Bool +okCstr All {} = True +okCstr Any {} = True +okCstr _ = False + + ------------------------------------------------------------------------------- --- | @Query@ is an NNF Horn Constraint. +-- | @Query@ is an NNF Horn Constraint. ------------------------------------------------------------------------------- -data Query a = Query - { qQuals :: ![F.Qualifier] -- ^ qualifiers over which to solve cstrs - , qVars :: ![Var a] -- ^ kvars, with parameter-sorts - , qCstr :: !(Cstr a) -- ^ list of constraints - , qCon :: M.HashMap (F.Symbol) (F.Sort) -- ^ list of constants (uninterpreted functions - , qDis :: M.HashMap (F.Symbol) (F.Sort) -- ^ list of constants (uninterpreted functions - , qEqns :: ![F.Equation] -- ^ list of equations - , qMats :: ![F.Rewrite] -- ^ list of match-es - , qData :: ![F.DataDecl] -- ^ list of data-declarations +data Query a = Query + { qQuals :: ![F.Qualifier] -- ^ qualifiers over which to solve cstrs + , qVars :: ![Var a] -- ^ kvars, with parameter-sorts + , qCstr :: !(Cstr a) -- ^ list of constraints + , qCon :: M.HashMap F.Symbol F.Sort -- ^ list of constants (uninterpreted functions + , qDis :: M.HashMap F.Symbol F.Sort -- ^ list of constants (uninterpreted functions + , qEqns :: ![F.Equation] -- ^ list of equations + , qMats :: ![F.Rewrite] -- ^ list of match-es + , qData :: ![F.DataDecl] -- ^ list of data-declarations } deriving (Data, Typeable, Generic, Functor) @@ -210,7 +211,7 @@ type TagVar = Var Tag type TagQuery = Query Tag data Tag = NoTag | Tag String - deriving (Data, Typeable, Generic, Show) + deriving (Data, Typeable, Generic, Show) instance NFData Tag @@ -218,19 +219,19 @@ srcSpan _ = F.dummySpan instance F.Fixpoint Tag where - toFix NoTag = "\"\"" + toFix NoTag = "\"\"" toFix (Tag s) = "\"" <> P.text s <> "\"" - + instance F.PPrint Tag where pprintPrec _ _ NoTag = mempty - pprintPrec _ _ (Tag s) = P.ptext s + pprintPrec _ _ (Tag s) = P.ptext s instance ToJSON Tag where toJSON NoTag = Null - toJSON (Tag s) = String (T.pack s) + toJSON (Tag s) = String (T.pack s) -instance F.PPrint (Query a) where - pprintPrec k t q = P.vcat $ L.intersperse " " +instance F.PPrint (Query a) where + pprintPrec k t q = P.vcat $ L.intersperse " " [ P.vcat (ppQual <$> qQuals q) , P.vcat [ppVar k | k <- qVars q] , P.vcat [ppCon x t | (x, t) <- M.toList (qCon q)] @@ -241,22 +242,24 @@ ppThings :: F.PPrint a => Maybe P.Doc -> [a] -> P.Doc ppThings pfx qs = P.vcat [ P.parens $ prefix P.<-> F.pprint q | q <- qs] - where - prefix = fromMaybe "" pfx + where + prefix = fromMaybe "" pfx ppCon :: F.Symbol -> F.Sort -> P.Doc ppCon x t = P.parens ("constant" P.<+> F.pprint x P.<+> P.parens (F.pprint t)) ppQual :: F.Qualifier -> P.Doc ppQual (F.Q n xts p _) = P.parens ("qualif" P.<+> F.pprint n P.<+> ppBlanks (ppArg <$> xts) P.<+> P.parens (F.pprint p)) - where - ppArg qp = F.pprint (F.qpSym qp) P.<+> P.parens (F.pprint (F.qpSort qp)) + where + ppArg qp = P.parens $ F.pprint (F.qpSym qp) P.<+> P.parens (F.pprint (F.qpSort qp)) ppVar :: Var a -> P.Doc -ppVar (HVar k ts _) = P.parens ("var" P.<+> "$" P.<-> F.pprint k P.<+> ppBlanks ((P.parens . F.pprint) <$> ts)) +ppVar (HVar k ts _) = P.parens ("var" P.<+> "$" P.<-> F.pprint k P.<+> ppBlanks (P.parens . F.pprint <$> ts)) + ppBlanks :: [P.Doc] -> P.Doc ppBlanks ds = P.parens (P.hcat (L.intersperse " " ds)) + ------------------------------------------------------------------------------- -- Pretty Printing ------------------------------------------------------------------------------- @@ -268,7 +271,7 @@ instance Show Pred where show (Reft p) = parens $ F.showpp p - show (Var x xs) = parens $ unwords (F.symbolString <$> x:xs) + show (Var x xs) = parens $ "$" ++ unwords (F.symbolString <$> x:xs) show (PAnd ps) = parens $ unwords $ "and": map show ps instance Show (Cstr a) where @@ -277,15 +280,15 @@ show (Any b c) = parens $ unwords ["exists" , show b , show c] show (CAnd cs) = parens $ unwords $ "and" : map show cs -instance Show Bind where - show (Bind x t p) = parens $ unwords [parens $ unwords [F.symbolString x, F.showpp t], show p] +instance Show (Bind a) where + show (Bind x t p _) = parens $ unwords [parens $ unwords [F.symbolString x, F.showpp t], show p] instance F.PPrint (Var a) where pprintPrec _ _ v = P.ptext $ show v instance F.PPrint Pred where pprintPrec k t (Reft p) = P.parens $ F.pprintPrec k t p - pprintPrec _ _ (Var x xs) = P.parens $ P.hsep (P.ptext . F.symbolString <$> x:xs) + pprintPrec _ _ (Var x xs) = P.parens $ P.ptext "$" <> P.hsep (P.ptext . F.symbolString <$> x:xs) pprintPrec k t (PAnd ps) = P.parens $ P.vcat $ P.ptext "and" : map (F.pprintPrec (k+2) t) ps instance F.PPrint (Cstr a) where @@ -298,5 +301,5 @@ ] pprintPrec k t (CAnd cs) = P.parens $ P.vcat $ P.ptext "and" : map (F.pprintPrec (k+2) t) cs -instance F.PPrint Bind where +instance F.PPrint (Bind a) where pprintPrec _ _ b = P.ptext $ show b diff --git a/src/Language/Fixpoint/Minimize.hs b/src/Language/Fixpoint/Minimize.hs --- a/src/Language/Fixpoint/Minimize.hs +++ b/src/Language/Fixpoint/Minimize.hs @@ -7,8 +7,11 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Minimize ( minQuery, minQuals, minKvars ) where +import Prelude hiding (min, init) import qualified Data.HashMap.Strict as M import Control.Monad (filterM) import Language.Fixpoint.Types.Visitor (mapKVars) @@ -16,7 +19,7 @@ import Language.Fixpoint.Misc (safeHead) import Language.Fixpoint.Utils.Files hiding (Result) import Language.Fixpoint.Graph -import Language.Fixpoint.Types +import Language.Fixpoint.Types hiding (fi) import Control.DeepSeq --------------------------------------------------------------------------- @@ -79,7 +82,7 @@ failFis <- filterM (fmap (not . isSafe) . solve cfg') fis let failFi = safeHead "--minimize can only be called on UNSAT fq" failFis let format _ cs = "Minimized Constraints: " ++ show (fst <$> cs) - let update fi cs = fi { cm = M.fromList cs } + let update fi' cs = fi' { cm = M.fromList cs } commonDebug (M.toList . cm) update (not . isSafe) True cfg' solve failFi Min format --------------------------------------------------------------------------- @@ -88,9 +91,9 @@ --------------------------------------------------------------------------- minQuals cfg solve fi = do let cfg' = cfg { minimizeQs = False } - let format fi qs = "Required Qualifiers: " ++ show (length qs) - ++ "; Total Qualifiers: " ++ show (length $ quals fi) - let update fi qs = fi { quals = qs } + let format fi' qs = "Required Qualifiers: " ++ show (length qs) + ++ "; Total Qualifiers: " ++ show (length $ quals fi') + let update fi' qs = fi' { quals = qs } commonDebug quals update isSafe False cfg' solve fi MinQuals format --------------------------------------------------------------------------- @@ -99,8 +102,8 @@ --------------------------------------------------------------------------- minKvars cfg solve fi = do let cfg' = cfg { minimizeKs = False } - let format fi ks = "Required KVars: " ++ show (length ks) - ++ "; Total KVars: " ++ show (length $ ws fi) + let format fi' ks = "Required KVars: " ++ show (length ks) + ++ "; Total KVars: " ++ show (length $ ws fi') commonDebug (M.keys . ws) removeOtherKs isSafe False cfg' solve fi MinKVars format removeOtherKs :: FInfo a -> [KVar] -> FInfo a diff --git a/src/Language/Fixpoint/Misc.hs b/src/Language/Fixpoint/Misc.hs --- a/src/Language/Fixpoint/Misc.hs +++ b/src/Language/Fixpoint/Misc.hs @@ -5,9 +5,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ImplicitParams #-} -- ignore hlint + module Language.Fixpoint.Misc where -- import System.IO.Unsafe (unsafePerformIO) @@ -56,14 +56,14 @@ hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)] hashMapToAscList = L.sortBy (compare `on` fst) . M.toList -findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a +findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a findNearest key kvs = argMin [ (abs (key - k), v) | (k, v) <- kvs ] -argMin :: (Ord k) => [(k, v)] -> Maybe v +argMin :: (Ord k) => [(k, v)] -> Maybe v argMin = fmap snd . headMb . L.sortBy (compare `on` fst) -headMb :: [a] -> Maybe a -headMb [] = Nothing +headMb :: [a] -> Maybe a +headMb [] = Nothing headMb (x:_) = Just x --------------------------------------------------------------- -- | Unique Int ----------------------------------------------- @@ -150,7 +150,7 @@ errorP :: String -> String -> a -errorP p s = error (p ++ s) +errorP p s = error (p ++ s) errorstar :: (?callStack :: CallStack) => String -> a errorstar = error . wrap (stars ++ "\n") (stars ++ "\n") @@ -224,7 +224,7 @@ hashNubWith f xs = M.elems $ M.fromList [ (f x, x) | x <- xs ] mFromList :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k v -mFromList = M.fromList +mFromList = M.fromList duplicates :: (Eq k, Hashable k) => [k] -> [k] duplicates xs = [ x | (x, n) <- count xs, 1 < n ] @@ -264,8 +264,8 @@ where -- dups = duplicates . fmap fst dups = [ x | (x, n) <- count (fst <$> kvs), 1 < n ] - err = errorstar . wrap "safeFromList with duplicates" msg . show - wrap m1 m2 s = m1 ++ " " ++ s ++ " " ++ m2 + err = errorstar . wrapMsg "safeFromList with duplicates" msg . show + wrapMsg m1 m2 s = m1 ++ " " ++ s ++ " " ++ m2 safeHead _ (x:_) = x safeHead msg _ = errorstar $ "safeHead with empty list " ++ msg @@ -307,16 +307,6 @@ ensurePath :: FilePath -> IO () ensurePath = createDirectoryIfMissing True . takeDirectory -singleton :: a -> [a] -singleton x = [x] - -pair :: a -> a -> [a] -pair x1 x2 = [x1, x2] - -triple :: a -> a -> a -> [a] -triple x1 x2 x3 = [x1, x2, x3] - - fM :: (Monad m) => (a -> b) -> a -> m b fM f = return . f @@ -325,10 +315,10 @@ b <- cond when b act -ifM :: (Monad m) => m Bool -> m a -> m a -> m a -ifM c t e = do - b <- c - if b then t else e +ifM :: (Monad m) => m Bool -> m a -> m a -> m a +ifM c t e = do + b <- c + if b then t else e mapEither :: (a -> Either b c) -> [a] -> ([b], [c]) mapEither _ [] = ([], []) @@ -338,8 +328,8 @@ where (ys, zs) = mapEither f xs -isRight :: Either a b -> Bool -isRight (Right _) = True +isRight :: Either a b -> Bool +isRight (Right _) = True isRight _ = False componentsWith :: (Ord c) => (a -> [(b, c, [c])]) -> a -> [[b]] @@ -357,8 +347,8 @@ -- | -- >>> let em = M.fromList [ (1, [2, 3]), (2, [1, 3]), (3, [] ) ] -- >>> let ef = \v -> (v, M.lookupDefault [] v em) --- >>> sccsWith ef [1,2,3] --- [[3],[1,2]] +-- >>> sccsWith ef [1,2,3] +-- [[3],[1,2]] sccsWith :: (Ord v) => (a -> (v, [v])) -> [a] -> [[a]] sccsWith vF xs = map (fst3 . f) <$> (T.flatten <$> G.scc g) @@ -412,49 +402,36 @@ {-@ allCombinations :: xss:[[a]] -> [{v:[a]| len v == len xss}] @-} allCombinations :: [[a]] -> [[a]] -allCombinations xs = assert (and . map (((length xs) == ) . length)) $ go xs +allCombinations xs = assert (all ((length xs == ) . length)) $ go xs where - go [] = [[]] - go [[]] = [] - go ([]:_) = [] - go ((x:xs):ys) = ((x:) <$> go ys) ++ go (xs:ys) + go [] = [[]] + go [[]] = [] + go ([]:_) = [] + go ((x:xs'):ys) = ((x:) <$> go ys) ++ go (xs':ys) assert b x = if b x then x else errorstar "allCombinations: assertion violation" powerset :: [a] -> [[a]] powerset xs = filterM (const [False, True]) xs +infixl 9 =>> (=>>) :: Monad m => m b -> (b -> m a) -> m b (=>>) m f = m >>= (\x -> f x >> return x) +infixl 9 <<= (<<=) :: Monad m => (b -> m a) -> m b -> m b (<<=) = flip (=>>) -(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b] -_ <$$> [] = return [] -f <$$> [x1] = singleton <$> f x1 -f <$$> [x1, x2] = pair <$> f x1 <*> f x2 -f <$$> [x1, x2, x3] = triple <$> f x1 <*> f x2 <*> f x3 -f <$$> xs = revMapM f ({- trace msg -} xs) - where - _msg = "<$$> on " ++ show (length xs) - -revMapM :: (Monad m) => (a -> m b) -> [a] -> m [b] -revMapM f = go [] - where - go !acc [] = return (reverse acc) - go !acc (x:xs) = do {!y <- f x; go (y:acc) xs} - -- Null if first is a subset of second -nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a +nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a nubDiff a b = a' `S.difference` b' where a' = S.fromList a b' = S.fromList b -fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a -fold1M _ [] = errorstar $ "fold1M with empty list" -fold1M _ [x] = return x -fold1M f (x1:x2:xs) = do { x <- f x1 x2; fold1M f (x:xs) } +fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a +fold1M _ [] = errorstar "fold1M with empty list" +fold1M _ [x] = return x +fold1M f (x1:x2:xs) = do { x <- f x1 x2; fold1M f (x:xs) } diff --git a/src/Language/Fixpoint/Parse.hs b/src/Language/Fixpoint/Parse.hs --- a/src/Language/Fixpoint/Parse.hs +++ b/src/Language/Fixpoint/Parse.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Parse ( -- * Top Level Class for Parseable Values @@ -124,7 +124,8 @@ import Language.Fixpoint.Types.Errors import qualified Language.Fixpoint.Misc as Misc import Language.Fixpoint.Smt.Types -import Language.Fixpoint.Types hiding (mapSort) +import Language.Fixpoint.Types hiding (mapSort, fi, params, GInfo(..)) +import qualified Language.Fixpoint.Types as Types (GInfo(FI)) import Text.PrettyPrint.HughesPJ (text, vcat, (<+>), Doc) import Control.Monad.State @@ -764,14 +765,14 @@ emptyListP :: Parser Expr emptyListP = do - e <- empList <$> get + e <- gets empList case e of Nothing -> fail "No parsing support for empty lists" Just s -> return s singletonListP :: Expr -> Parser Expr singletonListP e = do - f <- singList <$> get + f <- gets singList case f of Nothing -> fail "No parsing support for singleton lists" Just s -> return $ s e @@ -780,9 +781,8 @@ exprCastP :: Parser Expr exprCastP = do e <- exprP - try dcolon <|> colon -- allow : or :: *and* allow following symbols - so <- sortP - return $ ECst e so + _ <- try dcolon <|> colon -- allow : or :: *and* allow following symbols + ECst e <$> sortP fastIfP :: (Expr -> a -> a -> a) -> Parser a -> Parser a fastIfP f bodyP @@ -791,15 +791,13 @@ reserved "then" b1 <- bodyP reserved "else" - b2 <- bodyP - return $ f p b1 b2 + f p b1 <$> bodyP coerceP :: Parser Expr -> Parser Expr coerceP p = do reserved "coerce" (s, t) <- parens (pairP sortP (reservedOp "~") sortP) - e <- p - return $ ECoerc s t e + ECoerc s t <$> p @@ -860,7 +858,7 @@ -- | Parses any of the known infix operators. infixSymbolP :: Parser Symbol infixSymbolP = do - ops <- infixOps <$> get + ops <- gets infixOps choice (reserved' <$> ops) where infixOps st = [s | FInfix _ s _ _ <- fixityOps st] @@ -869,7 +867,7 @@ -- | Located version of 'infixSymbolP'. locInfixSymbolP :: Parser (Located Symbol) locInfixSymbolP = do - ops <- infixOps <$> get + ops <- gets infixOps choice (reserved' <$> ops) where infixOps st = [s | FInfix _ s _ _ <- fixityOps st] @@ -926,7 +924,7 @@ , FInfix (Just 9) "." applyCompose AssocRight ] applyCompose :: Maybe (Expr -> Expr -> Expr) - applyCompose = (\f x y -> (f `eApps` [x,y])) <$> cmpFun + applyCompose = (\f x y -> f `eApps` [x,y]) <$> cmpFun -- | Parser for function applications. -- @@ -952,24 +950,21 @@ return $ mkEApp (Loc l1 l2 cons) (first : rest) --- TODO:AZ: The comment says BitVector literal, but it accepts any @Sort@ --- | BitVector literal: lit "#x00000001" (BitVec (Size32 obj)) +-- | Parser for literals of all sorts. litP :: Parser Expr litP = do reserved "lit" l <- stringLiteral - t <- sortP - return $ ECon $ L (T.pack l) t + ECon . L (T.pack l) <$> sortP -- | Parser for lambda abstractions. lamP :: Parser Expr lamP = do reservedOp "\\" x <- symbolP - colon -- TODO: this should probably be reservedOp instead + _ <- colon -- TODO: this should probably be reservedOp instead t <- sortP reservedOp "->" - e <- exprP - return $ ELam (x, t) e + ELam (x, t) <$> exprP varSortP :: Parser Sort varSortP = FVar <$> parens intP @@ -979,8 +974,8 @@ funcSortP = parens $ mkFFunc <$> intP <* comma <*> sortsP sortsP :: Parser [Sort] -sortsP = try (brackets (sepBy sortP semi)) - <|> (brackets (sepBy sortP comma)) +sortsP = try (brackets (sepBy sortP semi)) + <|> brackets (sepBy sortP comma) -- | Parser for sorts (types). sortP :: Parser Sort @@ -1051,7 +1046,7 @@ <|> kvarPredP <|> fastIfP pIte predP -- "if-then-else", starts with "if" <|> try predrP -- binary relation, starts with anything that an expr can start with - <|> (parens predP) -- parenthesised predicate, starts with "(" + <|> parens predP -- parenthesised predicate, starts with "(" <|> (reservedOp "?" *> exprP) <|> try funAppP <|> EVar <$> symbolP -- identifier, starts with any letter or underscore @@ -1203,8 +1198,7 @@ x <- symbolP pat <- qualPatP _ <- colon - t <- tP - return $ QP x pat t + QP x pat <$> tP qualPatP :: Parser QualPattern qualPatP @@ -1256,7 +1250,7 @@ matchP = SMeasure <$> symbolP <*> symbolP <*> many symbolP <*> (reserved "=" >> exprP) pairsP :: Parser a -> Parser b -> Parser [(a, b)] -pairsP aP bP = brackets $ sepBy1 (pairP aP (reserved ":") bP) semi +pairsP aP bP = brackets $ sepBy (pairP aP (reserved ":") bP) semi --------------------------------------------------------------------- -- | Parsing Constraints (.fq files) -------------------------------- --------------------------------------------------------------------- @@ -1271,8 +1265,8 @@ | Qul !Qualifier | Kut !KVar | Pack !KVar !Int - | IBind !Int !Symbol !SortedReft - | EBind !Int !Symbol !Sort + | IBind !Int !Symbol !SortedReft !a + | EBind !Int !Symbol !Sort !a | Opt !String | Def !Equation | Mat !Rewrite @@ -1289,19 +1283,19 @@ return $ FIO (defsFInfo ps) [s | Opt s <- ps] fInfoP :: Parser (FInfo ()) -fInfoP = defsFInfo <$> {- SCC "many-defP" #-} many defP +fInfoP = defsFInfo <$> {- SCC "many-defP" -} many defP defP :: Parser (Def ()) defP = Srt <$> (reserved "sort" >> colon >> sortP) - <|> Cst <$> (reserved "constraint" >> colon >> {- SCC "subCP" #-} subCP) - <|> Wfc <$> (reserved "wf" >> colon >> {- SCC "wfCP" #-} wfCP) + <|> Cst <$> (reserved "constraint" >> colon >> {- SCC "subCP" -} subCP) + <|> Wfc <$> (reserved "wf" >> colon >> {- SCC "wfCP" -} wfCP) <|> Con <$> (reserved "constant" >> symbolP) <*> (colon >> sortP) <|> Dis <$> (reserved "distinct" >> symbolP) <*> (colon >> sortP) <|> Pack <$> (reserved "pack" >> kvarP) <*> (colon >> intP) <|> Qul <$> (reserved "qualif" >> qualifierP sortP) <|> Kut <$> (reserved "cut" >> kvarP) - <|> EBind <$> (reserved "ebind" >> intP) <*> symbolP <*> (colon >> braces sortP) - <|> IBind <$> (reserved "bind" >> intP) <*> symbolP <*> (colon >> sortedReftP) + <|> EBind <$> (reserved "ebind" >> intP) <*> symbolP <*> (colon >> braces sortP) <*> pure () + <|> IBind <$> (reserved "bind" >> intP) <*> symbolP <*> (colon >> sortedReftP) <*> pure () <|> Opt <$> (reserved "fixpoint" >> stringLiteral) <|> Def <$> (reserved "define" >> defineP) <|> Mat <$> (reserved "match" >> matchP) @@ -1318,9 +1312,11 @@ wfCP = do reserved "env" env <- envP reserved "reft" - r <- sortedReftP - let [w] = wfC env r () - return w + r <- sortedReftP + case wfC env r () of + [w] -> return w + [] -> error "Unexpected empty list in wfCP" + _:_:_ -> error "Expected a single element list in wfCP" subCP :: Parser (SubC ()) subCP = do pos <- getSourcePos @@ -1333,8 +1329,7 @@ reserved "id" i <- natural <* spaces tag <- tagP - pos' <- getSourcePos - return $ subC' env lhs rhs i tag pos pos' + subC' env lhs rhs i tag pos <$> getSourcePos subC' :: IBindEnv -> SortedReft @@ -1368,15 +1363,15 @@ <|> (reserved "False" >> return False) defsFInfo :: [Def a] -> FInfo a -defsFInfo defs = {- SCC "defsFI" #-} FI cm ws bs ebs lts dts kts qs binfo adts mempty mempty ae +defsFInfo defs = {- SCC "defsFI" -} Types.FI cm ws bs ebs lts dts kts qs binfo adts mempty mempty ae where cm = Misc.safeFromList "defs-cm" [(cid c, c) | Cst c <- defs] ws = Misc.safeFromList "defs-ws" [(i, w) | Wfc w <- defs, let i = Misc.thd3 (wrft w)] - bs = bindEnvFromList $ exBinds ++ [(n,x,r) | IBind n x r <- defs] - ebs = [ n | (n,_,_) <- exBinds] - exBinds = [(n, x, RR t mempty) | EBind n x t <- defs] + bs = bindEnvFromList $ exBinds ++ [(n,(x,r,a)) | IBind n x r a <- defs] + ebs = [ n | (n,_) <- exBinds] + exBinds = [(n, (x, RR t mempty, a)) | EBind n x t a <- defs] lts = fromListSEnv [(x, t) | Con x t <- defs] dts = fromListSEnv [(x, t) | Dis x t <- defs] kts = KS $ S.fromList [k | Kut k <- defs] @@ -1387,14 +1382,14 @@ rews = [r | Mat r <- defs] autoRWs = M.fromList [(arId , s) | AutoRW arId s <- defs] rwEntries = [(i, f) | RWMap fs <- defs, (i,f) <- fs] - rwMap = foldl insert (M.fromList []) rwEntries + rwMap = foldl' insert (M.fromList []) rwEntries where - insert map (cid, arId) = + insert map' (cid', arId) = case M.lookup arId autoRWs of Just rewrite -> - M.insertWith (++) (fromIntegral cid) [rewrite] map + M.insertWith (++) (fromIntegral cid') [rewrite] map' Nothing -> - map + map' cid = fromJust . sid ae = AEnv eqs rews expand rwMap adts = [d | Adt d <- defs] @@ -1414,7 +1409,7 @@ crashP pp = do i <- pp msg <- takeWhileP Nothing (const True) -- consume the rest of the input - return $ Crash [i] msg + return $ Crash [(i, Nothing)] msg predSolP :: Parser Expr predSolP = parens (predP <* (comma >> iQualP)) @@ -1547,10 +1542,10 @@ rr' = doParse' solutionFileP instance Inputable (FInfo ()) where - rr' = {- SCC "fInfoP" #-} doParse' fInfoP + rr' = {- SCC "fInfoP" -} doParse' fInfoP instance Inputable (FInfoWithOpts ()) where - rr' = {- SCC "fInfoWithOptsP" #-} doParse' fInfoOptP + rr' = {- SCC "fInfoWithOptsP" -} doParse' fInfoOptP instance Inputable Command where rr' = doParse' commandP diff --git a/src/Language/Fixpoint/Smt/Bitvector.hs b/src/Language/Fixpoint/Smt/Bitvector.hs --- a/src/Language/Fixpoint/Smt/Bitvector.hs +++ b/src/Language/Fixpoint/Smt/Bitvector.hs @@ -28,6 +28,7 @@ import GHC.Generics (Generic) import Language.Fixpoint.Types.Names import Language.Fixpoint.Types +import Data.List (foldl') data Bv = Bv !BvSize !String @@ -57,7 +58,7 @@ -- | Apply some bitvector operator to a list of arguments eOp :: BvOp -> [Expr] -> Expr -eOp b es = foldl EApp (EVar $ opName b) es +eOp b es = foldl' EApp (EVar $ opName b) es opName :: BvOp -> Symbol opName BvAnd = bvAndName diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -8,6 +8,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains an SMTLIB2 interface for -- 1. checking the validity, and, -- 2. computing satisfying assignments @@ -106,10 +108,6 @@ import Data.Char import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import qualified Data.Text as T -- import Data.Text.Format import qualified Data.Text.IO as TIO @@ -203,14 +201,14 @@ smtWrite me !s = smtWriteRaw me s smtRead :: Context -> IO Response -smtRead me = {- SCC "smtRead" #-} do +smtRead me = {- SCC "smtRead" -} do when (ctxVerbose me) $ LTIO.putStrLn "SMT READ" ln <- smtReadRaw me res <- A.parseWith (smtReadRaw me) responseP ln case A.eitherResult res of Left e -> Misc.errorstar $ "SMTREAD:" ++ e Right r -> do - maybe (return ()) (\h -> LTIO.hPutStrLn h $ blt ("; SMT Says: " <> (bShow r))) (ctxLog me) + maybe (return ()) (\h -> LTIO.hPutStrLn h $ blt ("; SMT Says: " <> bShow r)) (ctxLog me) when (ctxVerbose me) $ LTIO.putStrLn $ blt ("SMT Says: " <> bShow r) return r @@ -219,13 +217,13 @@ type SmtParser a = Parser T.Text a responseP :: SmtParser Response -responseP = {- SCC "responseP" #-} A.char '(' *> sexpP +responseP = {- SCC "responseP" -} A.char '(' *> sexpP <|> A.string "sat" *> return Sat <|> A.string "unsat" *> return Unsat <|> A.string "unknown" *> return Unknown sexpP :: SmtParser Response -sexpP = {- SCC "sexpP" #-} A.string "error" *> (Error <$> errorP) +sexpP = {- SCC "sexpP" -} A.string "error" *> (Error <$> errorP) <|> Values <$> valuesP errorP :: SmtParser T.Text @@ -235,20 +233,20 @@ valuesP = A.many1' pairP <* A.char ')' pairP :: SmtParser (Symbol, T.Text) -pairP = {- SCC "pairP" #-} +pairP = {- SCC "pairP" -} do A.skipSpace - A.char '(' + _ <- A.char '(' !x <- symbolP A.skipSpace !v <- valueP - A.char ')' + _ <- A.char ')' return (x,v) symbolP :: SmtParser Symbol -symbolP = {- SCC "symbolP" #-} symbol <$> A.takeWhile1 (not . isSpace) +symbolP = {- SCC "symbolP" -} symbol <$> A.takeWhile1 (not . isSpace) valueP :: SmtParser T.Text -valueP = {- SCC "valueP" #-} negativeP +valueP = {- SCC "valueP" -} negativeP <|> A.takeWhile1 (\c -> not (c == ')' || isSpace c)) negativeP :: SmtParser T.Text @@ -256,18 +254,23 @@ = do v <- A.char '(' *> A.takeWhile1 (/=')') <* A.char ')' return $ "(" <> v <> ")" -smtWriteRaw :: Context -> Raw -> IO () -smtWriteRaw me !s = {- SCC "smtWriteRaw" #-} do +-- | Writes a line of input for the SMT solver and to the log if there is one. +smtWriteRaw :: Context -> Raw -> IO () +smtWriteRaw me !s = {- SCC "smtWriteRaw" -} do -- whenLoud $ do LTIO.appendFile debugFile (s <> "\n") -- LTIO.putStrLn ("CMD-RAW:" <> s <> ":CMD-RAW:DONE") - hPutStrLnNow (ctxCout me) s + hPutStrLnNow (ctxIn me) s maybe (return ()) (`LTIO.hPutStrLn` s) (ctxLog me) -smtReadRaw :: Context -> IO T.Text -smtReadRaw me = {- SCC "smtReadRaw" #-} TIO.hGetLine (ctxCin me) +-- | Reads a line of output from the SMT solver. +smtReadRaw :: Context -> IO T.Text +smtReadRaw me = do + eof <- hIsEOF (ctxOut me) + if eof then Misc.errorstar "SMT returned End of File" else + TIO.hGetLine (ctxOut me) {-# SCC smtReadRaw #-} -hPutStrLnNow :: Handle -> LT.Text -> IO () +hPutStrLnNow :: Handle -> LT.Text -> IO () hPutStrLnNow h !s = LTIO.hPutStrLn h s >> hFlush h {-# SCC hPutStrLnNow #-} @@ -307,7 +310,7 @@ makeProcess :: Config -> IO Context makeProcess cfg - = do (hOut, hIn, _ ,pid) <- runInteractiveCommand $ smtCmd (solver cfg) + = do (hIn, hOut, _ ,pid) <- runInteractiveCommand $ smtCmd (solver cfg) loud <- isLoud hSetBuffering hOut $ BlockBuffering $ Just $ 1024*1024*64 hSetBuffering hIn $ BlockBuffering $ Just $ 1024*1024*64 @@ -320,11 +323,11 @@ when (LT.null t) retry writeTVar queueTVar mempty return t - LTIO.hPutStr hOut t - hFlush hOut + LTIO.hPutStr hIn t + hFlush hIn return Ctx { ctxPid = pid - , ctxCin = hIn - , ctxCout = hOut + , ctxIn = hIn + , ctxOut = hOut , ctxLog = Nothing , ctxVerbose = loud , ctxSymEnv = mempty @@ -332,13 +335,12 @@ , ctxTVar = queueTVar } --------------------------------------------------------------------------- +-- | Close file handles and wait for the solver process to terminate. cleanupContext :: Context -> IO ExitCode --------------------------------------------------------------------------- -cleanupContext (Ctx {..}) = do +cleanupContext Ctx{..} = do cancel ctxAsync - hCloseMe "ctxCin" ctxCin - hCloseMe "ctxCout" ctxCout + hCloseMe "ctxIn" ctxIn + hCloseMe "ctxOut" ctxOut maybe (return ()) (hCloseMe "ctxLog") ctxLog waitForProcess ctxPid @@ -354,37 +356,39 @@ smtCmd Mathsat = "mathsat -input=smt2" smtCmd Cvc4 = "cvc4 --incremental -L smtlib2" --- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2... smtPreamble :: Config -> SMTSolver -> Context -> IO [LT.Text] smtPreamble cfg Z3 me - = do smtWrite me "(get-info :version)" - v:_ <- T.words . (!!1) . T.splitOn "\"" <$> smtReadRaw me + = do v <- getZ3Version me checkValidStringFlag Z3 v cfg - if T.splitOn "." v `versionGreaterEq` ["4", "3", "2"] - then return $ z3_432_options ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3 - else return $ z3_options ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3 + return $ z3_options ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3 smtPreamble cfg s _ - = checkValidStringFlag s "" cfg >> return (Thy.preamble cfg s) + = checkValidStringFlag s [] cfg >> return (Thy.preamble cfg s) -checkValidStringFlag :: SMTSolver -> T.Text -> Config -> IO () +getZ3Version :: Context -> IO [Int] +getZ3Version me + = do smtWrite me "(get-info :version)" + -- resp is like (:version "4.8.15") + resp <- smtReadRaw me + case T.splitOn "\"" resp of + _:vText:_ -> do + let parsedComponents = [ reads (T.unpack cText) | cText <- T.splitOn "." vText ] + sequence + [ case pComponent of + [(c, "")] -> return c + xs -> error $ "Can't parse z3 version: " ++ show xs + | pComponent <- parsedComponents + ] + xs -> error $ "Can't parse z3 (get-info :version): " ++ show xs + +checkValidStringFlag :: SMTSolver -> [Int] -> Config -> IO () checkValidStringFlag smt v cfg = when (noString smt v cfg) $ die $ err dummySpan (text "stringTheory is only supported by z3 version >=4.2.2") -noString :: SMTSolver -> T.Text -> Config -> Bool +noString :: SMTSolver -> [Int] -> Config -> Bool noString smt v cfg = stringTheory cfg - && not (smt == Z3 && (T.splitOn "." v `versionGreaterEq` ["4", "4", "2"])) - - -versionGreaterEq :: Ord a => [a] -> [a] -> Bool -versionGreaterEq (x:xs) (y:ys) - | x > y = True - | x == y = versionGreaterEq xs ys - | x < y = False -versionGreaterEq _ [] = True -versionGreaterEq [] _ = False -versionGreaterEq _ _ = Misc.errorstar "Interface.versionGreater called with bad arguments" + && not (smt == Z3 && (v >= [4, 4, 2])) ----------------------------------------------------------------------------- -- | SMT Commands ----------------------------------------------------------- @@ -512,7 +516,7 @@ makeTimeout :: Config -> [LT.Text] makeTimeout cfg - | Just i <- smtTimeout cfg = [ LT.pack ("\n(set-option :timeout " ++ (show i) ++ ")\n")] + | Just i <- smtTimeout cfg = [ LT.pack ("\n(set-option :timeout " ++ show i ++ ")\n")] | otherwise = [""] @@ -521,23 +525,15 @@ | gradual cfg = [""] | otherwise = ["\n(set-option :smt.mbqi false)"] --- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2... -z3_432_options :: [LT.Text] -z3_432_options - = [ "(set-option :auto-config false)" - , "(set-option :model true)" - , "(set-option :model.partial false)"] - z3_options :: [LT.Text] z3_options = [ "(set-option :auto-config false)" - , "(set-option :model true)" - , "(set-option :model-partial false)"] + , "(set-option :model true)" ] -------------------------------------------------------------------------------- -declare :: Context -> IO () -- SolveM () +declare :: Context -> IO () -------------------------------------------------------------------------------- declare me = do forM_ dss $ smtDataDecl me @@ -555,7 +551,7 @@ thyXTs = filter (isKind 1) xts qryXTs = Misc.mapSnd tx <$> filter (isKind 2) xts isKind n = (n ==) . symKind env . fst - xts = {- tracepp "symbolSorts" $ -} symbolSorts (F.seSort env) + xts = {- tracepp "symbolSorts" $ -} symbolSorts (F.seSort env) tx = elaborate "declare" env ats = funcSortVars env @@ -609,4 +605,3 @@ tess = Misc.groupList [(t, F.expr x) | (x, t) <- xts, notFun t] notFun = not . F.isFunctionSortedReft . (`F.RR` F.trueReft) -- _notStr = not . (F.strSort ==) . F.sr_sort . (`F.RR` F.trueReft) - diff --git a/src/Language/Fixpoint/Smt/Serialize.hs b/src/Language/Fixpoint/Smt/Serialize.hs --- a/src/Language/Fixpoint/Smt/Serialize.hs +++ b/src/Language/Fixpoint/Smt/Serialize.hs @@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DoAndIfThenElse #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the code for serializing Haskell values -- into SMTLIB2 format, that is, the instances for the @SMTLIB2@ -- typeclass. We split it into a separate module as it depends on @@ -18,9 +20,6 @@ import qualified Language.Fixpoint.Types.Visitor as Vis import Language.Fixpoint.Smt.Types import qualified Language.Fixpoint.Smt.Theories as Thy -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif -- import Data.Text.Format import Language.Fixpoint.Misc (sortNub, errorstar) @@ -46,12 +45,12 @@ , parens $ smt2many (smt2datactors env <$> ds) ] - + smt2dataname :: SymEnv -> DataDecl -> Builder.Builder smt2dataname env (DDecl tc as _) = parenSeqs [name, n] where name = smt2 env (symbol tc) - n = smt2 env as + n = smt2 env as smt2datactors :: SymEnv -> DataDecl -> Builder.Builder @@ -59,12 +58,12 @@ where tvars = smt2many (smt2TV <$> [0..(as-1)]) smt2TV = smt2 env . SVar - ds = smt2many (smt2ctor env as <$> cs) + ds = smt2many (smt2ctor env as <$> cs) smt2ctor :: SymEnv -> Int -> DataCtor -> Builder.Builder smt2ctor env _ (DCtor c []) = smt2 env c smt2ctor env as (DCtor c fs) = parenSeqs [smt2 env c, fields] - + where fields = smt2many (smt2field env as <$> fs) @@ -101,8 +100,8 @@ | Just t <- Thy.smt2Symbol env s = t smt2 _ s = symbolBuilder s -instance SMTLIB2 Int where - smt2 _ = Builder.fromString . show +instance SMTLIB2 Int where + smt2 _ = Builder.fromString . show instance SMTLIB2 LocSymbol where smt2 env = smt2 env . val @@ -148,14 +147,14 @@ smt2 _ (PAnd []) = "true" smt2 env (PAnd ps) = parenSeqs ["and", smt2s env ps] smt2 _ (POr []) = "false" - smt2 env (POr ps) = parenSeqs ["or", smt2s env ps] + smt2 env (POr ps) = parenSeqs ["or", smt2s env ps] smt2 env (PNot p) = parenSeqs ["not", smt2 env p] smt2 env (PImp p q) = parenSeqs ["=>", smt2 env p, smt2 env q] smt2 env (PIff p q) = parenSeqs ["=", smt2 env p, smt2 env q] smt2 env (PExist [] p) = smt2 env p smt2 env (PExist bs p) = parenSeqs ["exists", parens (smt2s env bs), smt2 env p] smt2 env (PAll [] p) = smt2 env p - smt2 env (PAll bs p) = parenSeqs ["forall", parens (smt2s env bs), smt2 env p] + smt2 env (PAll bs p) = parenSeqs ["forall", parens (smt2s env bs), smt2 env p] smt2 env (PAtom r e1 e2) = mkRel env r e1 e2 smt2 env (ELam b e) = smt2Lam env b e smt2 env (ECoerc t1 t2 e) = smt2Coerc env t1 t2 e @@ -205,13 +204,13 @@ (f, es) = splitEApp' e smt2Coerc :: SymEnv -> Sort -> Sort -> Expr -> Builder.Builder -smt2Coerc env t1 t2 e +smt2Coerc env t1 t2 e | t1' == t2' = smt2 env e | otherwise = parenSeqs [Builder.fromText coerceFn , smt2 env e] - where + where coerceFn = symbolAtName coerceName env (ECoerc t1 t2 e) t t = FFunc t1 t2 - t1' = smt2SortMono e env t1 + t1' = smt2SortMono e env t1 t2' = smt2SortMono e env t2 splitEApp' :: Expr -> (Expr, [Expr]) @@ -242,13 +241,13 @@ | length az < 2 = "" | otherwise = key "assert" (key "distinct" (smt2s env az)) smt2 env (AssertAx t) = key "assert" (smt2 env t) - smt2 _ (Push) = "(push 1)" - smt2 _ (Pop) = "(pop 1)" - smt2 _ (CheckSat) = "(check-sat)" + smt2 _ Push = "(push 1)" + smt2 _ Pop = "(pop 1)" + smt2 _ CheckSat = "(check-sat)" smt2 env (GetValue xs) = key "key-value" (parens (smt2s env xs)) smt2 env (CMany cmds) = smt2many (smt2 env <$> cmds) - smt2 _ (Exit) = "(exit)" - smt2 _ (SetMbqi) = "(set-option :smt.mbqi true)" + smt2 _ Exit = "(exit)" + smt2 _ SetMbqi = "(set-option :smt.mbqi true)" instance SMTLIB2 (Triggered Expr) where smt2 env (TR NoTrigger e) = smt2 env e @@ -257,10 +256,10 @@ smt2 env (TR _ (PAll [] p)) = smt2 env p smt2 env t@(TR _ (PAll bs p)) = smtTr env "forall" bs p t smt2 env (TR _ e) = smt2 env e - + {-# INLINE smtTr #-} smtTr :: SymEnv -> Builder.Builder -> [(Symbol, Sort)] -> Expr -> Triggered Expr -> Builder.Builder -smtTr env q bs p t = key q (parens (smt2s env bs) <+> key "!" (smt2 env p <+> ":pattern" <> parens (smt2s env (makeTriggers t)))) +smtTr env q bs p t = key q (parens (smt2s env bs) <+> key "!" (smt2 env p <+> ":pattern" <> parens (smt2s env (makeTriggers t)))) {-# INLINE smt2s #-} smt2s :: SMTLIB2 a => SymEnv -> [a] -> Builder.Builder diff --git a/src/Language/Fixpoint/Smt/Theories.hs b/src/Language/Fixpoint/Smt/Theories.hs --- a/src/Language/Fixpoint/Smt/Theories.hs +++ b/src/Language/Fixpoint/Smt/Theories.hs @@ -4,7 +4,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Smt.Theories ( -- * Convert theory applications TODO: merge with smt2symbol @@ -38,10 +42,6 @@ ) where import Prelude hiding (map) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Language.Fixpoint.Types.Sorts import Language.Fixpoint.Types.Config import Language.Fixpoint.Types @@ -71,7 +71,8 @@ set = "LSet" map = "Map" -emp, sng, add, cup, cap, mem, dif, sub, com, sel, sto, mcup, mdef :: Raw +emp, sng, add, cup, cap, mem, dif, sub, com, sel, sto, mcup, mdef, mprj :: Raw +mToSet, mshift, mmax, mmin :: Raw emp = "smt_set_emp" sng = "smt_set_sng" add = "smt_set_add" @@ -84,10 +85,16 @@ sel = "smt_map_sel" sto = "smt_map_sto" mcup = "smt_map_cup" +mmax = "smt_map_max" +mmin = "smt_map_min" mdef = "smt_map_def" +mprj = "smt_map_prj" +mshift = "smt_map_shift" +mToSet = "smt_map_to_set" -setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: Symbol +setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup :: Symbol +setDif, setSng :: Symbol setEmpty = "Set_empty" setEmp = "Set_emp" setCap = "Set_cap" @@ -99,12 +106,51 @@ setDif = "Set_dif" setSng = "Set_sng" -mapSel, mapSto, mapCup, mapDef :: Symbol +mapSel, mapSto, mapCup, mapDef, mapPrj, mapToSet :: Symbol +mapMax, mapMin, mapShift :: Symbol mapSel = "Map_select" mapSto = "Map_store" mapCup = "Map_union" +mapMax = "Map_union_max" +mapMin = "Map_union_min" mapDef = "Map_default" +mapPrj = "Map_project" +mapShift = "Map_shift" -- See [Map key shift] +mapToSet = "Map_to_set" +-- [Interaction between Map and Set] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Function mapToSet: Convert a map to a set. The map's key may be of +-- any type and is preserved as the set's element type. More precisely: +-- mapToSet : Map k Int -> Set k +-- The element type must be Int. All non-positive elements are mapped +-- to False, and all positive elements are mapped to True. In practice, +-- negative elements should not exist because Map is intended to be used +-- as a bag, so the element is a non-negative number representing +-- the occurrences of its corresponding key. +-- +-- Function mapPrj: Project a subset of a map. Type signature: +-- mapPrj : Set k -> Map k Int -> Map k Int +-- If the key is present in both the argument set and the argument map, +-- then the key (along with its associated value in the map) are preserved +-- in the output. Keys not present in the set are mapped to zero. Keys not +-- present in the set are mapped to zero. +-- +-- [Map key shift] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Function mapShift: Add an integer to all keys in a map. Type signature: +-- mapShift : Int -> Map Int v -> Map Int v +-- Let's call the first argument (the shift amount) N, the second argument K1, +-- and the result K2. For all indices i, we have K2[i] = K1[i - N]. +-- This is implemented with Z3's lambda, which lets us construct an array +-- from a function. +-- +-- [Map max and min] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Functions mapMax and mapMin: Union two maps, combining the elements by +-- taking either the greatest (mapMax) or the least (mapMin) of them. +-- mapMax, mapMin : Map v Int -> Map v Int -> Map v Int + strLen, strSubstr, strConcat :: (IsString a) => a -- Symbol strLen = "strLen" strSubstr = "subString" @@ -139,62 +185,101 @@ z3Preamble :: Config -> [T.Text] z3Preamble u = stringPreamble u ++ - [ bSort elt + [ bSort elt "Int" - , bSort set + , bSort set (key2 "Array" (bb elt) "Bool") - , bFun emp - [] - (bb set) + , bFun emp + [] + (bb set) (parens (key "as const" (bb set) <+> "false")) , bFun sng [("x", bb elt)] (bb set) (key3 "store" (parens (key "as const" (bb set) <+> "false")) "x" "true") - , bFun mem - [("x", bb elt), ("s", bb set)] + , bFun mem + [("x", bb elt), ("s", bb set)] "Bool" "(select s x)" , bFun add - [("s", bb set), ("x", bb elt)] + [("s", bb set), ("x", bb elt)] (bb set) "(store s x true)" - , bFun cup - [("s1", bb set), ("s2", bb set)] + , bFun cup + [("s1", bb set), ("s2", bb set)] (bb set) "((_ map or) s1 s2)" - , bFun cap - [("s1", bb set), ("s2", bb set)] + , bFun cap + [("s1", bb set), ("s2", bb set)] (bb set) "((_ map and) s1 s2)" , bFun com - [("s", bb set)] + [("s", bb set)] (bb set) "((_ map not) s)" - , bFun dif - [("s1", bb set), ("s2", bb set)] + , bFun dif + [("s1", bb set), ("s2", bb set)] (bb set) (key2 (bb cap) "s1" (key (bb com) "s2")) , bFun sub [("s1", bb set), ("s2", bb set)] "Bool" - (key2 "=" (bb emp) (key2 (bb dif) "s1" "s2")) + (key2 "=" (bb emp) (key2 (bb dif) "s1" "s2")) - -- Maps + -- Maps , bSort map (key2 "Array" (bb elt) (bb elt)) , bFun sel [("m", bb map), ("k", bb elt)] - (bb elt) + (bb elt) "(select m k)" , bFun sto [("m", bb map), ("k", bb elt), ("v", bb elt)] - (bb map) + (bb map) "(store m k v)" , bFun mcup [("m1", bb map), ("m2", bb map)] (bb map) (key2 (key "_ map" (key2 "+" (parens (bb elt <+> bb elt)) (bb elt))) "m1" "m2") + , bFun mprj -- See [Interaction Between Map and Set] + [("s", bb set), ("m", bb map)] + (bb map) + (key3 + (key "_ map" + (key2 "ite" + (parens ("Bool" <+> bb elt <+> bb elt)) + (bb elt) + ) + ) + "s" + "m" + (parens (key "as const" (key2 "Array" (bb elt) (bb elt)) <+> "0")) + ) + , bFun mToSet -- See [Interaction Between Map and Set] + [("m", bb map)] + (bb set) + (key2 + (key "_ map" + (key2 ">" + (parens (bb elt <+> bb elt)) + "Bool" + ) + ) + "m" + (parens (key "as const" (key2 "Array" (bb elt) (bb elt)) <+> "0")) + ) + , bFun mmax -- See [Map max and min] + [("m1", bb map),("m2", bb map)] + (bb map) + "(lambda ((i Int)) (ite (> (select m1 i) (select m2 i)) (select m1 i) (select m2 i)))" + , bFun mmin -- See [Map max and min] + [("m1", bb map),("m2", bb map)] + (bb map) + "(lambda ((i Int)) (ite (< (select m1 i) (select m2 i)) (select m1 i) (select m2 i)))" + , bFun mshift -- See [Map key shift] + [("n", "Int"),("m", bb map)] + (bb map) + "(lambda ((i Int)) (select m (- i n)))" , bFun mdef [("v", bb elt)] (bb map) @@ -204,19 +289,19 @@ "Int" "(ite b 1 0)" - , uifDef u (symbolLText mulFuncName) "*" + , uifDef u (symbolLText mulFuncName) "*" , uifDef u (symbolLText divFuncName) "div" ] symbolLText :: Symbol -> T.Text -symbolLText = T.fromStrict . symbolText +symbolLText = T.fromStrict . symbolText -- RJ: Am changing this to `Int` not `Real` as (1) we usually want `Int` and -- (2) have very different semantics. TODO: proper overloading, post genEApp uifDef :: Config -> T.Text -> T.Text -> T.Text uifDef cfg f op | linear cfg || Z3 /= solver cfg - = bFun' f ["Int", "Int"] "Int" + = bFun' f ["Int", "Int"] "Int" | otherwise = bFun f [("x", "Int"), ("y", "Int")] "Int" (key2 (bb op) "x" "y") @@ -231,7 +316,7 @@ = [ bSort elt "Int" , bSort set "Int" , bSort string "Int" - , bFun' emp [] (bb set) + , bFun' emp [] (bb set) , bFun' sng [bb elt] (bb set) , bFun' add [bb set, bb elt] (bb set) , bFun' cup [bb set, bb set] (bb set) @@ -243,7 +328,7 @@ ] cvc4MapPreamble :: Config -> [T.Text] -cvc4MapPreamble _ = +cvc4MapPreamble _ = [ bSort map (key2 "Array" (bb elt) (bb elt)) , bFun sel [("m", bb map), ("k", bb elt)] (bb elt) "(select m k)" , bFun sto [("m", bb map), ("k", bb elt), ("v", bb elt)] (bb map) "(store m k v)" @@ -251,7 +336,7 @@ smtlibPreamble :: Config -> [T.Text] smtlibPreamble z --TODO use uif flag u (see z3Preamble) - = commonPreamble z + = commonPreamble z ++ [ bSort map "Int" , bFun' sel [bb map, bb elt] (bb elt) , bFun' sto [bb map, bb elt, bb elt] (bb map) @@ -259,7 +344,7 @@ stringPreamble :: Config -> [T.Text] stringPreamble cfg | stringTheory cfg - = [ bSort string "String" + = [ bSort string "String" , bFun strLen [("s", bb string)] "Int" (key (bb z3strlen) "s") , bFun strSubstr [("s", bb string), ("i", "Int"), ("j", "Int")] (bb string) (key (bb z3strsubstr) "s i j") , bFun strConcat [("x", bb string), ("y", bb string)] (bb string) (key (bb z3strconcat) "x y") @@ -267,7 +352,7 @@ stringPreamble _ = [ bSort string "Int" - , bFun' strLen [bb string] "Int" + , bFun' strLen [bb string] "Int" , bFun' strSubstr [bb string, "Int", "Int"] (bb string) , bFun' strConcat [bb string, bb string] (bb string) ] @@ -302,7 +387,7 @@ -------------------------------------------------------------------------------- smt2App :: VarAs -> SymEnv -> Expr -> [Builder] -> Maybe Builder -------------------------------------------------------------------------------- -smt2App _ _ (ECst (EVar f) _) [d] +smt2App _ _ (dropECst -> EVar f) [d] | f == setEmpty = Just (bb emp) | f == setEmp = Just (key2 "=" (bb emp) d) | f == setSng = Just (key (bb sng) d) -- Just (key2 (bb add) (bb emp) d) @@ -314,10 +399,10 @@ smt2App _ _ _ _ = Nothing smt2AppArg :: VarAs -> SymEnv -> Expr -> Maybe Builder -smt2AppArg k env (ECst (EVar f) t) +smt2AppArg k env (ECst (dropECst -> EVar f) t) | Just fThy <- symEnvTheory f env = Just $ if isPolyCtor fThy t - then (k env f (ffuncOut t)) + then k env f (ffuncOut t) else bb (tsRaw fThy) smt2AppArg _ _ _ @@ -332,7 +417,7 @@ -------------------------------------------------------------------------------- isSmt2App :: SEnv TheorySymbol -> Expr -> Maybe Int -------------------------------------------------------------------------------- -isSmt2App g (EVar f) +isSmt2App g (dropECst -> EVar f) | f == setEmpty = Just 1 | f == setEmp = Just 1 | f == setSng = Just 1 @@ -385,7 +470,12 @@ , interpSym mapSel sel mapSelSort , interpSym mapSto sto mapStoSort , interpSym mapCup mcup mapCupSort + , interpSym mapMax mmax mapMaxSort + , interpSym mapMin mmin mapMinSort , interpSym mapDef mdef mapDefSort + , interpSym mapPrj mprj mapPrjSort + , interpSym mapShift mshift mapShiftSort + , interpSym mapToSet mToSet mapToSetSort , interpSym bvOrName "bvor" bvBopSort , interpSym bvAndName "bvand" bvBopSort , interpSym strLen strLen strLenSort @@ -404,6 +494,15 @@ mapCupSort = FAbs 0 $ FFunc (mapSort (FVar 0) intSort) $ FFunc (mapSort (FVar 0) intSort) (mapSort (FVar 0) intSort) + mapMaxSort = mapCupSort + mapMinSort = mapCupSort + mapPrjSort = FAbs 0 $ FFunc (setSort (FVar 0)) + $ FFunc (mapSort (FVar 0) intSort) + (mapSort (FVar 0) intSort) + mapShiftSort = FAbs 0 $ FFunc intSort + $ FFunc (mapSort intSort (FVar 0)) + (mapSort intSort (FVar 0)) + mapToSetSort = FAbs 0 $ FFunc (mapSort (FVar 0) intSort) (setSort (FVar 0)) mapStoSort = FAbs 0 $ FAbs 1 $ FFunc (mapSort (FVar 0) (FVar 1)) $ FFunc (FVar 0) $ FFunc (FVar 1) diff --git a/src/Language/Fixpoint/Smt/Types.hs b/src/Language/Fixpoint/Smt/Types.hs --- a/src/Language/Fixpoint/Smt/Types.hs +++ b/src/Language/Fixpoint/Smt/Types.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the types defining an SMTLIB2 interface. module Language.Fixpoint.Smt.Types ( @@ -73,14 +75,14 @@ ppCmd (DeclData d) = text "Data" <+> pprint d ppCmd (Declare x [] t) = text "Declare" <+> text (T.unpack x) <+> text ":" <+> pprint t ppCmd (Declare x ts t) = text "Declare" <+> text (T.unpack x) <+> text ":" <+> parens (pprint ts) <+> pprint t -ppCmd (Define {}) = text "Define ..." +ppCmd Define {} = text "Define ..." ppCmd (DefineFunc name params rsort e) = text "DefineFunc" <+> pprint name <+> pprint params <+> pprint rsort <+> pprint e ppCmd (Assert _ e) = text "Assert" <+> pprint e ppCmd (AssertAx _) = text "AssertAxiom ..." -ppCmd (Distinct {}) = text "Distinct ..." -ppCmd (GetValue {}) = text "GetValue ..." -ppCmd (CMany {}) = text "CMany ..." +ppCmd Distinct {} = text "Distinct ..." +ppCmd GetValue {} = text "GetValue ..." +ppCmd CMany {} = text "CMany ..." -- | Responses received from SMT engine data Response = Ok @@ -94,12 +96,13 @@ -- | Information about the external SMT process data Context = Ctx { ctxPid :: !ProcessHandle - , ctxCin :: !Handle - , ctxCout :: !Handle + -- | The handle for writing queries to, for input to the SMT solver. + , ctxIn :: !Handle + -- | The handle for reading responses from, the output from the SMT solver. + , ctxOut :: !Handle , ctxLog :: !(Maybe Handle) , ctxVerbose :: !Bool , ctxSymEnv :: !SymEnv - -- | The handle of the thread writing queries to the SMT solver , ctxAsync :: Async () -- | The next batch of queries to send to the SMT solver , ctxTVar :: TVar Builder diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs --- a/src/Language/Fixpoint/Solver.hs +++ b/src/Language/Fixpoint/Solver.hs @@ -3,11 +3,11 @@ -- either as .fq files or as FInfo. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver ( -- * Invoke Solver on an FInfo solve, Solver @@ -54,11 +54,13 @@ import Language.Fixpoint.Utils.Statistics (statistics) import Language.Fixpoint.Graph import Language.Fixpoint.Parse (rr') -import Language.Fixpoint.Types +import Language.Fixpoint.Types hiding (GInfo(..), fi) +import qualified Language.Fixpoint.Types as Types (GInfo(..)) import Language.Fixpoint.Minimize (minQuery, minQuals, minKvars) import Language.Fixpoint.Solver.Instantiate (instantiate) import Control.DeepSeq import qualified Data.ByteString as B +import Data.Maybe (catMaybes) --------------------------------------------------------------------------- -- | Solve an .fq file ---------------------------------------------------- @@ -74,22 +76,22 @@ file = srcFile cfg --------------------------------------------------------------------------- -resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a +resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a -> IO ExitCode --------------------------------------------------------------------------- -resultExitCode cfg r = do +resultExitCode cfg r = do whenNormal $ colorStrLn (colorResult stat) (statStr $!! stat) when (json cfg) $ LT.putStrLn jStr return (eCode r) - where + where jStr = LT.decodeUtf8 . encode $ r stat = resStatus $!! r eCode = resultExit . resStatus - statStr = render . resultDoc + statStr = render . resultDoc ignoreQualifiers :: Config -> FInfo a -> FInfo a ignoreQualifiers cfg fi - | eliminate cfg == All = fi { quals = [] } + | eliminate cfg == All = fi { Types.quals = [] } | otherwise = fi @@ -126,15 +128,15 @@ readFq :: FilePath -> IO (FInfo (), [String]) readFq file = do str <- readFile file - let q = {- SCC "parsefq" #-} rr' file str :: FInfoWithOpts () + let q = {- SCC "parsefq" -} rr' file str :: FInfoWithOpts () return (fioFI q, fioOpts q) readBinFq :: FilePath -> IO (FInfo ()) -readBinFq file = {-# SCC "parseBFq" #-} do +readBinFq file = {-# SCC "parseBFq" #-} do bs <- B.readFile file - case S.decode bs of + case S.decode bs of Right fi -> return fi - Left err -> error ("Error decoding .bfq: " ++ show err) + Left err' -> error ("Error decoding .bfq: " ++ show err') -------------------------------------------------------------------------------- -- | Solve in parallel after partitioning an FInfo to indepdendant parts @@ -163,7 +165,7 @@ [onePart] -> s c onePart _ -> inParallelUsing (f s c) $ zip [1..] fis where - f s c (j, fi) = s (c {srcFile = queryFile (Part j) c}) fi + f s' c' (j, fi) = s' (c {srcFile = queryFile (Part j) c'}) fi -------------------------------------------------------------------------------- -- | Solve a list of FInfos using the provided solver function in parallel @@ -181,15 +183,35 @@ -------------------------------------------------------------------------------- solveNative, solveNative' :: (NFData a, Fixpoint a, Show a, Loc a) => Solver a -------------------------------------------------------------------------------- -solveNative !cfg !fi0 = (solveNative' cfg fi0) +solveNative !cfg !fi0 = solveNative' cfg fi0 `catch` - (return . result) + (return . crashResult (errorMap fi0)) -result :: Error -> Result a -result e = Result (Crash [] msg) mempty mempty mempty +crashResult :: ErrorMap a -> Error -> Result (Integer, a) +crashResult m e = Result res mempty mempty mempty where - msg = showpp e + res = Crash es msg + es = catMaybes [ findError m e | e <- errs e ] + msg | null es = showpp e + | otherwise = "Sorry, unexpected panic in liquid-fixpoint!" +-- | Unpleasant hack to save meta-data that can be recovered from SrcSpan +type ErrorMap a = HashMap.HashMap SrcSpan a + +findError :: ErrorMap a -> Error1 -> Maybe ((Integer, a), Maybe String) +findError m e = do + ann <- HashMap.lookup (errLoc e) m + let str = render (errMsg e) + return ((-1, ann), Just str) + +-- The order is important here: we want the "binders" to get the "precedence" +errorMap :: (Loc a) => FInfo a -> ErrorMap a +errorMap fi = HashMap.fromList [ (srcSpan a, a) | a <- anns ] + where + anns = [ sinfo c | (_, c) <- HashMap.toList (Types.cm fi) ] + ++ [ winfo w | (_, w) <- HashMap.toList (Types.ws fi) ] + ++ [ a | (_, (_,_, a)) <- bindEnvToList (Types.bs fi) ] + loudDump :: (Fixpoint a) => Int -> Config -> SInfo a -> IO () loudDump i cfg si = when False (writeLoud $ msg ++ render (toFixpoint cfg si)) where @@ -205,32 +227,32 @@ -- whenLoud $ print qs -- whenLoud $ putStrLn $ showFix (quals fi1) reducedFi <- reduceFInfo cfg fi0 - let fi1 = reducedFi { quals = remakeQual <$> quals reducedFi } - let si0 = {- SCC "convertFormat" #-} convertFormat fi1 + let fi1 = reducedFi { Types.quals = remakeQual <$> Types.quals reducedFi } + let si0 = {- SCC "convertFormat" -} convertFormat fi1 -- writeLoud $ "fq file after format convert: \n" ++ render (toFixpoint cfg si0) -- rnf si0 `seq` donePhase Loud "Format Conversion" - let si1 = either die id $ ({- SCC "sanitize" #-} sanitize cfg $!! si0) + let si1 = either die id ({- SCC "sanitize" -} sanitize cfg $!! si0) -- writeLoud $ "fq file after sanitize: \n" ++ render (toFixpoint cfg si1) -- rnf si1 `seq` donePhase Loud "Validated Constraints" graphStatistics cfg si1 - let si2 = {- SCC "wfcUniqify" #-} wfcUniqify $!! si1 - let si3 = {- SCC "renameAll" #-} renameAll $!! si2 + let si2 = {- SCC "wfcUniqify" -} wfcUniqify $!! si1 + let si3 = {- SCC "renameAll" -} renameAll $!! si2 rnf si3 `seq` whenLoud $ donePhase Loud "Uniqify & Rename" loudDump 1 cfg si3 - let si4 = {- SCC "defunction" #-} defunctionalize cfg $!! si3 + let si4 = {- SCC "defunction" -} defunctionalize cfg $!! si3 -- putStrLn $ "AXIOMS: " ++ showpp (asserts si4) loudDump 2 cfg si4 - let si5 = {- SCC "elaborate" #-} elaborate (atLoc dummySpan "solver") (symbolEnv cfg si4) si4 + let si5 = {- SCC "elaborate" -} elaborate (atLoc dummySpan "solver") (symbolEnv cfg si4) si4 loudDump 3 cfg si5 - let si6 = if extensionality cfg then {- SCC "expand" #-} expand cfg si5 else si5 + let si6 = if extensionality cfg then {- SCC "expand" -} expand cfg si5 else si5 if rewriteAxioms cfg && noLazyPLE cfg then instantiate cfg si6 $!! Nothing else return si6 reduceFInfo :: Fixpoint a => Config -> FInfo a -> IO (FInfo a) reduceFInfo cfg fi = do - let simplifiedFi = {- SCC "simplifyFInfo" #-} simplifyBindings cfg fi - reducedFi = {- SCC "reduceEnvironments" #-} reduceEnvironments simplifiedFi + let simplifiedFi = {- SCC "simplifyFInfo" -} simplifyBindings cfg fi + reducedFi = {- SCC "reduceEnvironments" -} reduceEnvironments simplifiedFi when (save cfg) $ savePrettifiedQuery cfg reducedFi if noEnvironmentReduction cfg then @@ -240,7 +262,7 @@ solveNative' !cfg !fi0 = do si6 <- simplifyFInfo cfg fi0 - res <- {- SCC "Sol.solve" #-} Sol.solve cfg $!! si6 + res <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6 -- rnf soln `seq` donePhase Loud "Solve2" --let stat = resStatus res -- saveSolution cfg res @@ -260,9 +282,9 @@ parseFI f = do str <- readFile f let fi = rr' f str :: FInfo () - return $ mempty { quals = quals fi - , gLits = gLits fi - , dLits = dLits fi } + return $ mempty { Types.quals = Types.quals fi + , Types.gLits = Types.gLits fi + , Types.dLits = Types.dLits fi } saveSolution :: Config -> Result a -> IO () saveSolution cfg res = when (save cfg) $ do diff --git a/src/Language/Fixpoint/Solver/Common.hs b/src/Language/Fixpoint/Solver/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Common.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Language.Fixpoint.Solver.Common (askSMT, toSMT) where + +import Language.Fixpoint.Types.Config (Config) +import Language.Fixpoint.Smt.Interface (Context(..), checkValidWithContext) +import Language.Fixpoint.Types +import Language.Fixpoint.Types.Visitor (kvarsExpr) +import Language.Fixpoint.Defunctionalize (defuncAny) +import Language.Fixpoint.SortCheck (elaborate) + +mytracepp :: (PPrint a) => String -> a -> a +mytracepp = notracepp + +askSMT :: Config -> Context -> [(Symbol, Sort)] -> Expr -> IO Bool +askSMT cfg ctx bs e +-- | isContraPred e = return False + | isTautoPred e = return True + | null (kvarsExpr e) = checkValidWithContext ctx [] PTrue e' + | otherwise = return False + where + e' = toSMT "askSMT" cfg ctx bs e + +toSMT :: String -> Config -> Context -> [(Symbol, Sort)] -> Expr -> Pred +toSMT msg cfg ctx bs e = + defuncAny cfg senv . + elaborate (dummyLoc msg) (elabEnv bs) . + mytracepp ("toSMT from " ++ msg ++ showpp e) $ + e + where + elabEnv = insertsSymEnv senv + senv = ctxSymEnv ctx diff --git a/src/Language/Fixpoint/Solver/Eliminate.hs b/src/Language/Fixpoint/Solver/Eliminate.hs --- a/src/Language/Fixpoint/Solver/Eliminate.hs +++ b/src/Language/Fixpoint/Solver/Eliminate.hs @@ -29,13 +29,14 @@ where cD = elimDeps sI es nKs ebs sI' = cutSInfo sI kI cKs - sHyp = Sol.fromList sE mempty mempty kHyps kS [] $ fromListSEnv [ (x, (i, sr_sort sr)) | (i,x,sr) <- bindEnvToList (bs sI)] + sHyp = Sol.fromList sE mempty mempty kHyps kS [] sEnv + sEnv = fromListSEnv [ (x, (i, sr_sort sr)) | (i, (x,sr, _)) <- bindEnvToList (bs sI)] kHyps = nonCutHyps sI kI nKs kI = kIndex sI (es, cKs, nKs) = kutVars cfg sI kS = kvScopes sI es sE = symbolEnv cfg sI - ebs = S.fromList $ fst <$> flip lookupBindEnv (bs sI) <$> (ebinds sI) + ebs = S.fromList [x | i <- ebinds sI, let (x, _, _) = lookupBindEnv i (bs sI) ] -------------------------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/EnvironmentReduction.hs b/src/Language/Fixpoint/Solver/EnvironmentReduction.hs --- a/src/Language/Fixpoint/Solver/EnvironmentReduction.hs +++ b/src/Language/Fixpoint/Solver/EnvironmentReduction.hs @@ -1,19 +1,27 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | Functions to make environments smaller module Language.Fixpoint.Solver.EnvironmentReduction ( reduceEnvironments , simplifyBindings , dropLikelyIrrelevantBindings + , inlineInExpr , inlineInSortedReft , mergeDuplicatedBindings , simplifyBooleanRefts , undoANF + , undoANFAndVV + + -- for use in tests + , undoANFSimplifyingWith ) where import Control.Monad (guard, mplus, msum) @@ -29,7 +37,7 @@ import Data.ShareMap (ShareMap) import qualified Data.ShareMap as ShareMap import qualified Data.Text as Text -import Language.Fixpoint.SortCheck (exprSort_maybe) +import Language.Fixpoint.SortCheck (exprSortMaybe) import Language.Fixpoint.Types.Config import Language.Fixpoint.Types.Constraints import Language.Fixpoint.Types.Environments @@ -55,6 +63,7 @@ , isPrefixOfSym , prefixOfSym , symbolText + , vvName ) import Language.Fixpoint.Types.PrettyPrint import Language.Fixpoint.Types.Refinements @@ -65,6 +74,7 @@ , Subst(..) , pattern PTrue , pattern PFalse + , dropECst , expr , exprKVars , exprSymbolsSet @@ -78,6 +88,9 @@ ) import Language.Fixpoint.Types.Sorts (boolSort, sortSymbols) import Language.Fixpoint.Types.Visitor (mapExprOnExpr) +import Lens.Family2 (Lens', view, (%~)) +import Lens.Family2.Stock (_2) +import Language.Fixpoint.Misc (snd3) -- | Strips from all the constraint environments the bindings that are -- irrelevant for their respective constraints. @@ -140,10 +153,10 @@ where dropBindsMissingFrom - :: HashMap BindId (Symbol, SortedReft) + :: HashMap BindId (Symbol, SortedReft, a) -> [(SubcId, SubC a)] -> HashMap KVar (WfC a) - -> HashMap BindId (Symbol, SortedReft) + -> HashMap BindId (Symbol, SortedReft, a) dropBindsMissingFrom be cs ws = let ibindEnv = unionsIBindEnv $ map (senv . snd) cs ++ @@ -168,7 +181,7 @@ -- 'relatedKVarBinds' or any substitution on the corresponding KVar anywhere. -- reduceWFConstraintEnvironments - :: BindEnv -- ^ Environment before reduction + :: BindEnv a -- ^ Environment before reduction -> ([ReducedConstraint a], HashMap KVar (WfC a)) -- ^ @(cs, ws)@: -- * @cs@ are the constraints with reduced environments @@ -183,8 +196,7 @@ HashMap.map (sortSymbols . (\(_, b, _) -> b) . wrft) wfs kvarsRelevantBinds = - HashMap.unionWith HashSet.union wfBindsPlusSortSymbols $ - kvarSubstSymbols + HashMap.unionWith HashSet.union wfBindsPlusSortSymbols kvarSubstSymbols ws' = HashMap.mapWithKey @@ -209,7 +221,7 @@ -- additional bindings that are required by the kvar. These are added -- in this function. updateSubcEnvsWithKVarBinds - :: BindEnv + :: BindEnv a -> HashMap KVar (HashSet Symbol) -> [KVar] -> ReducedConstraint a @@ -221,7 +233,7 @@ else fromListIBindEnv [ bId | bId <- elemsIBindEnv oldEnv - , let (s, _sr) = lookupBindEnv bId be + , let (s, _sr, _) = lookupBindEnv bId be , any (neededByKVar s) kvs ] neededByKVar s kv = @@ -233,7 +245,7 @@ -- @reduceWFConstraintEnvironment be kbinds k c@ drops bindings from @c@ -- that aren't present in @kbinds ! k@. reduceWFConstraintEnvironment - :: BindEnv + :: BindEnv a -> HashMap KVar (HashSet Symbol) -> KVar -> WfC a @@ -246,7 +258,7 @@ where relevantBindIds :: HashSet Symbol -> BindId -> Bool relevantBindIds kbindSymbols bId = - let (s, _) = lookupBindEnv bId bindEnv + let (s, _, _) = lookupBindEnv bId bindEnv in HashSet.member s kbindSymbols data ReducedConstraint a = ReducedConstraint @@ -256,18 +268,18 @@ } reduceConstraintEnvironment - :: BindEnv + :: BindEnv a -> HashMap Symbol (HashSet Symbol) -> (SubcId, SubC a) -> ReducedConstraint a reduceConstraintEnvironment bindEnv aenvMap (cid, c) = - let env = [ (s, bId, sr) + let env = [ (s, bId, sr, a) | bId <- elemsIBindEnv $ senv c - , let (s, sr) = lookupBindEnv bId bindEnv + , let (s, sr, a) = lookupBindEnv bId bindEnv ] prunedEnv = fromListIBindEnv - [ bId | (_, bId, _) <- dropIrrelevantBindings aenvMap constraintSymbols env ] + [ bId | (_, bId, _,_) <- dropIrrelevantBindings aenvMap constraintSymbols env ] constraintSymbols = HashSet.union (sortedReftSymbols $ slhs c) (sortedReftSymbols $ srhs c) in ReducedConstraint @@ -288,17 +300,17 @@ dropIrrelevantBindings :: HashMap Symbol (HashSet Symbol) -> HashSet Symbol - -> [(Symbol, BindId, SortedReft)] - -> [(Symbol, BindId, SortedReft)] + -> [(Symbol, BindId, SortedReft, a)] + -> [(Symbol, BindId, SortedReft, a)] dropIrrelevantBindings aenvMap extraSymbols env = filter relevantBind env where allSymbols = reachableSymbols (HashSet.union extraSymbols envSymbols) aenvMap envSymbols = - HashSet.unions $ map (\(_, _, sr) -> sortedReftSymbols sr) env + HashSet.unions $ map (\(_, _, sr,_) -> sortedReftSymbols sr) env - relevantBind (s, _, sr) + relevantBind (s, _, sr, _) | HashSet.member s allSymbols = True | otherwise = case reftPred (sr_reft sr) of PTrue -> False @@ -365,7 +377,7 @@ -- be needed by the other. -- relatedKVarBinds - :: BindEnv + :: BindEnv a -> [ReducedConstraint a] -> (HashMap KVar (HashSet Symbol), HashMap KVar (HashSet Symbol), [[KVar]]) relatedKVarBinds bindEnv cs = @@ -382,7 +394,7 @@ where kvarsByBindId :: HashMap BindId (HashMap KVar [Subst]) kvarsByBindId = - HashMap.map (exprKVars . reftPred . sr_reft . snd) $ beBinds bindEnv + HashMap.map (exprKVars . reftPred . sr_reft . snd3) $ beBinds bindEnv -- Returns all of the KVars used in the constraint, together with -- the symbols that appear in substitutions of those KVars. @@ -418,12 +430,12 @@ let sm' = ShareMap.insertWith unionIBindEnv k bindIds sm in foldr (ShareMap.mergeKeysWith unionIBindEnv k) sm' ks -asSymbolSet :: BindEnv -> IBindEnv -> HashSet Symbol +asSymbolSet :: BindEnv a -> IBindEnv -> HashSet Symbol asSymbolSet be ibinds = HashSet.fromList [ s | bId <- elemsIBindEnv ibinds - , let (s, _) = lookupBindEnv bId be + , let (s, _,_) = lookupBindEnv bId be ] -- | @reachableSymbols x r@ computes the set of symbols reachable from @x@ @@ -446,7 +458,7 @@ -- It runs 'mergeDuplicatedBindings' and 'simplifyBooleanRefts' -- on the environment of each constraint. -- --- If 'inlineANFBindings cfg' is on, also runs 'undoANF' to inline +-- If 'inlineANFBindings cfg' is on, also runs 'undoANFAndVV' to inline -- @lq_anf@ bindings. simplifyBindings :: Config -> FInfo a -> FInfo a simplifyBindings cfg fi = @@ -474,39 +486,39 @@ ] simplifyConstraints - :: BindEnv + :: BindEnv a -> HashMap SubcId (SubC a) - -> (BindEnv, HashMap SubcId (SubC a), HashMap BindId [BindId]) + -> (BindEnv a, HashMap SubcId (SubC a), HashMap BindId [BindId]) simplifyConstraints be cs = let (be', cs', newToOld) = HashMap.foldlWithKey' simplifyConstraintBindings (be, [], []) cs oldToNew = HashMap.fromListWith (++) $ - concatMap (\(n, olds) -> map (\o -> (o, [n])) olds) newToOld + concatMap (\(n, olds) -> map (, [n]) olds) newToOld in (be', HashMap.fromList cs', oldToNew) simplifyConstraintBindings - :: (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])]) + :: (BindEnv a, [(SubcId, SubC a)], [(BindId, [BindId])]) -> SubcId -> SubC a - -> (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])]) + -> (BindEnv a, [(SubcId, SubC a)], [(BindId, [BindId])]) simplifyConstraintBindings (bindEnv, cs, newToOld) cid c = let env = - [ (s, ([bId], sr)) + [ (s, ([(bId, a)], sr)) | bId <- elemsIBindEnv $ senv c - , let (s, sr) = lookupBindEnv bId bindEnv + , let (s, sr, a) = lookupBindEnv bId bindEnv ] mergedEnv = mergeDuplicatedBindings env undoANFEnv = - if inlineANFBindings cfg then undoANF mergedEnv else HashMap.empty + if inlineANFBindings cfg then undoANFOnlyModified mergedEnv else HashMap.empty boolSimplEnv = simplifyBooleanRefts $ HashMap.union undoANFEnv mergedEnv modifiedBinds = HashMap.toList $ HashMap.union boolSimplEnv undoANFEnv - modifiedBindIds = map (fst . snd) modifiedBinds + modifiedBindIds = [ fst <$> bs | (_, (bs,_)) <- modifiedBinds ] unchangedBindIds = senv c `diffIBindEnv` fromListIBindEnv (concat modifiedBindIds) @@ -518,9 +530,9 @@ in (bindEnv', (cid, updateSEnv c (const newIBindEnv)) : cs, newToOld') - insertBinds = foldl' $ \(xs, be) (s, (_, sr)) -> - let (bId, be') = insertBindEnv s sr be - in (bId : xs, be') + insertBinds = foldl' $ \(xs, be) (s, (bIdAs, sr)) -> + let (bId, be') = insertBindEnv s sr (snd . head $ bIdAs) be + in (bId : xs, be') -- | If the environment contains duplicated bindings, they are -- combined with conjunctions. @@ -559,45 +571,75 @@ ] ) --- | Inlines some of the bindings introduced by ANF normalization --- at their use sites. +-- | Inlines some of the bindings whose symbol satisfies a given predicate. -- --- Only modified bindings are returned. +-- Only works if the bindings don't form cycles. +substBindingsSimplifyingWith + :: (SortedReft -> SortedReft) + -> Lens' v SortedReft + -> (Symbol -> Bool) + -> HashMap Symbol v + -> HashMap Symbol v +substBindingsSimplifyingWith simplifier vLens p env = + -- Circular program here. This should terminate as long as the + -- bindings introduced by ANF don't form cycles. + let env' = HashMap.map (vLens %~ simplifier . inlineInSortedReft (srLookup filteredEnv)) env + filteredEnv = HashMap.filterWithKey (\sym _v -> p sym) env' + in env' + where + srLookup env' sym = view vLens <$> HashMap.lookup sym env' + +substBindings + :: Lens' v SortedReft + -> (Symbol -> Bool) + -> HashMap Symbol v + -> HashMap Symbol v +substBindings = substBindingsSimplifyingWith simplify + +-- | Like 'substBindings' but specialized for ANF bindings. -- --- Only bindings with prefix lq_anf... might be inlined. +-- Only bindings with prefix lq_anf$... might be inlined. -- +undoANFSimplifyingWith :: (SortedReft -> SortedReft) -> Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v +undoANFSimplifyingWith simplifier vLens = substBindingsSimplifyingWith simplifier vLens $ \sym -> anfPrefix `isPrefixOfSym` sym + +undoANF :: Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v +undoANF = undoANFSimplifyingWith simplify + +-- | Like 'undoANF' but also inlines VV bindings +-- -- This function is used to produced the prettified output, and the user -- can request to use it in the verification pipeline with -- @--inline-anf-bindings@. However, using it in the verification -- pipeline causes some tests in liquidhaskell to blow up. -undoANF :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft) -undoANF env = - -- Circular program here. This should terminate as long as the - -- bindings introduced by ANF don't form cycles. - let env' = HashMap.map (inlineInSortedReftChanged env') env - in HashMap.mapMaybe dropUnchanged env' - where - dropUnchanged ((m, b), sr) = do - guard b - Just (m, sr) +-- +-- Note: This function simplifies. +undoANFAndVV :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft) +undoANFAndVV = substBindings _2 $ \sym -> anfPrefix `isPrefixOfSym` sym || vvName `isPrefixOfSym` sym -inlineInSortedReft - :: HashMap Symbol (m, SortedReft) -> SortedReft -> SortedReft -inlineInSortedReft env sr = - snd $ inlineInSortedReftChanged env (error "never should evaluate", sr) +-- | Like 'undoANF' but returns only modified bindings and **DOES NOT SIMPLIFY**. +undoANFOnlyModified :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft) +undoANFOnlyModified env = + let undoANFEnv = undoANFSimplifyingWith id _2 env + in HashMap.differenceWith dropUnchanged env undoANFEnv + where + dropUnchanged (_, a) v@(_, b) | a == b = Just v + | otherwise = Nothing -- | Inlines bindings in env in the given 'SortedReft'. --- Attaches a 'Bool' telling if the 'SortedReft' was changed. -inlineInSortedReftChanged - :: HashMap Symbol (a, SortedReft) - -> (m, SortedReft) - -> ((m, Bool), SortedReft) -inlineInSortedReftChanged env (m, sr) = - let e = reftPred (sr_reft sr) - e' = inlineInExpr env e - in ((m, e /= e'), sr { sr_reft = mapPredReft (const e') (sr_reft sr) }) +inlineInSortedReft + :: (Symbol -> Maybe SortedReft) + -> SortedReft + -> SortedReft +inlineInSortedReft srLookup sr = + let reft = sr_reft sr + in sr { sr_reft = mapPredReft (inlineInExpr (filterBind (reftBind reft) srLookup)) reft } + where + filterBind b srLookup sym = do + guard (sym /= b) + srLookup sym --- | Inlines bindings preffixed with @lq_anf@ in the given expression +-- | Inlines bindings given by @srLookup@ in the given expression -- if they appear in equalities. -- -- Given a binding like @a : { v | v = e1 && e2 }@ and an expression @... e0 = a ...@, @@ -610,23 +652,17 @@ -- Given a binding like @a : { v | v = e1 }@ and an expression @... a ...@, -- this function produces the expression @... e1 ...@ if @v@ does not -- appear free in @e1@. --- --- The first parameter indicates the maximum amount of conjuncts that a --- binding is allowed to have. If the binding exceeds this threshold, it --- is not inlined. -inlineInExpr :: HashMap Symbol (m, SortedReft) -> Expr -> Expr -inlineInExpr env = simplify . mapExprOnExpr inlineExpr +inlineInExpr :: (Symbol -> Maybe SortedReft) -> Expr -> Expr +inlineInExpr srLookup = mapExprOnExpr inlineExpr where inlineExpr (EVar sym) - | anfPrefix `isPrefixOfSym` sym - , Just (_, sr) <- HashMap.lookup sym env + | Just sr <- srLookup sym , let r = sr_reft sr , Just e <- isSingletonE (reftBind r) (reftPred r) = wrapWithCoercion Eq (sr_sort sr) e inlineExpr (PAtom br e0 e1@(dropECst -> EVar sym)) - | anfPrefix `isPrefixOfSym` sym - , isEq br - , Just (_, sr) <- HashMap.lookup sym env + | isEq br + , Just sr <- srLookup sym , let r = sr_reft sr , Just e <- isSingletonE (reftBind r) (reftPred r) = @@ -648,14 +684,9 @@ isEq r = r == Eq || r == Ueq - wrapWithCoercion br to e = case exprSort_maybe e of + wrapWithCoercion br to e = case exprSortMaybe e of Just from -> if from /= to then ECoerc from to e else e Nothing -> if br == Ueq then ECst e to else e - -dropECst :: Expr -> Expr -dropECst = \case - ECst e _t -> dropECst e - e -> e -- | Transforms bindings of the form @{v:bool | v && P v}@ into -- @{v:Bool | v && P true}@, and bindings of the form @{v:bool | ~v && P v}@ diff --git a/src/Language/Fixpoint/Solver/Extensionality.hs b/src/Language/Fixpoint/Solver/Extensionality.hs --- a/src/Language/Fixpoint/Solver/Extensionality.hs +++ b/src/Language/Fixpoint/Solver/Extensionality.hs @@ -1,116 +1,121 @@ -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module Language.Fixpoint.Solver.Extensionality (expand) where import Control.Monad.State import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe) +import Data.List (foldl') import Language.Fixpoint.Types.Config import Language.Fixpoint.SortCheck import Language.Fixpoint.Solver.Sanitize (symbolEnv) import Language.Fixpoint.Types hiding (mapSort, Pos) -import Language.Fixpoint.Types.Visitor ( (<$$>), mapSort ) +import Language.Fixpoint.Types.Visitor (mapSort) mytracepp :: (PPrint a) => String -> a -> a -mytracepp = notracepp +mytracepp = notracepp expand :: Config -> SInfo a -> SInfo a -expand cfg si = evalState (extend si) $ initST (symbolEnv cfg si) (ddecls si) +expand cfg si = evalState (ext si) $ initST (symbolEnv cfg si) (ddecls si) + where + ext ::SInfo a -> Ex a (SInfo a) + ext = extend -class Extend a where - extend :: a -> Ex a +class Extend ann a where + extend :: a -> Ex ann a -instance Extend (SInfo a) where - extend si = do +instance Extend a (SInfo a) where + extend si = do setBEnv (bs si) - cm' <- extend (cm si) - bs' <- exbenv <$> get + cm' <- extend (cm si) + bs' <- gets exbenv return $ si{ cm = cm' , bs = bs' } -instance (Extend a) => Extend (M.HashMap SubcId a) where - extend h = M.fromList <$> mapM extend (M.toList h) +instance (Extend ann a) => Extend ann (M.HashMap SubcId a) where + extend h = M.fromList <$> mapM extend (M.toList h) -instance (Extend a, Extend b) => Extend (a,b) where - extend (a,b) = (,) <$> extend a <*> extend b +instance (Extend ann a, Extend ann b) => Extend ann (a,b) where + extend (a,b) = (,) <$> extend a <*> extend b -instance Extend SubcId where - extend i = return i +instance Extend ann SubcId where + extend i = return i -instance Extend (SimpC a) where - extend c = do +instance Extend a (SimpC a) where + extend c = do setExBinds (_cenv c) - rhs <- extendExpr Pos (_crhs c) - is <- exbinds <$> get + rhs <- extendExpr (sinfo c) Pos (_crhs c) + is <- gets exbinds return $ c{_crhs = rhs, _cenv = is } -extendExpr :: Pos -> Expr -> Ex Expr -extendExpr p e - | p == Pos - = mapMPosExpr Pos goP e' >>= mapMPosExpr Pos goN +extendExpr :: a -> Pos -> Expr -> Ex a Expr +extendExpr ann p e + | p == Pos + = mapMPosExpr Pos goP e' >>= mapMPosExpr Pos goN | otherwise - = mapMPosExpr Neg goP e' >>= mapMPosExpr Neg goN - where + = mapMPosExpr Neg goP e' >>= mapMPosExpr Neg goN + where e' = normalize e goP Pos (PAtom b e1 e2) - | b == Eq || b == Ne + | b == Eq || b == Ne , Just s <- getArg (exprSort "extensionality" e1) - = mytracepp ("extending POS = " ++ showpp e) <$> (extendRHS b e1 e2 s >>= goP Pos) - goP _ e = return e + = mytracepp ("extending POS = " ++ showpp e) <$> (extendRHS ann b e1 e2 s >>= goP Pos) + goP _ e = return e goN Neg (PAtom b e1 e2) | b == Eq || b == Ne , Just s <- getArg (exprSort "extensionality" e1) - = mytracepp ("extending NEG = " ++ showpp e) <$> (extendLHS b e1 e2 s >>= goN Neg) - goN _ e = return e - -getArg :: Sort -> Maybe Sort -getArg s = case bkFFunc s of - Just (_,(a:_:_)) -> Just a - _ -> Nothing + = mytracepp ("extending NEG = " ++ showpp e) <$> (extendLHS ann b e1 e2 s >>= goN Neg) + goN _ e = return e -extendRHS, extendLHS :: Brel -> Expr -> Expr -> Sort -> Ex Expr -extendRHS b e1 e2 s = - do es <- generateArguments s - (mytracepp "extendRHS = " . pAnd) <$> mapM (makeEq b e1 e2) es +getArg :: Sort -> Maybe Sort +getArg s = case bkFFunc s of + Just (_, a:_:_) -> Just a + _ -> Nothing -extendLHS b e1 e2 s = - do es <- generateArguments s - dds <- exddecl <$> get - is <- instantiate dds s - (mytracepp "extendLHS = " . pAnd . (PAtom b e1 e2:)) <$> mapM (makeEq b e1 e2) (es ++ is) +extendRHS, extendLHS :: a -> Brel -> Expr -> Expr -> Sort -> Ex a Expr +extendRHS ann b e1 e2 s = + do es <- generateArguments ann s + mytracepp "extendRHS = " . pAnd <$> mapM (makeEq b e1 e2) es +extendLHS ann b e1 e2 s = + do es <- generateArguments ann s + dds <- gets exddecl + is <- instantiate ann dds s + mytracepp "extendLHS = " . pAnd . (PAtom b e1 e2:) <$> mapM (makeEq b e1 e2) (es ++ is) -generateArguments :: Sort -> Ex [Expr] -generateArguments s = do - st <- get - case breakSort (exddecl st) s of - Left dds -> mapM freshArgDD dds - Right s -> (\x -> [EVar x]) <$> freshArgOne s +generateArguments :: a -> Sort -> Ex a [Expr] +generateArguments ann s = do + ddecls <- gets exddecl + case breakSort ddecls s of + Left dds -> mapM (freshArgDD ann) dds + Right s -> (\x -> [EVar x]) <$> freshArgOne ann s -makeEq :: Brel-> Expr -> Expr -> Expr -> Ex Expr -makeEq b e1 e2 e = do - env <- exenv <$> get +makeEq :: Brel-> Expr -> Expr -> Expr -> Ex ann Expr +makeEq b e1 e2 e = do + env <- gets exenv let elab = elaborate (dummyLoc "extensionality") env return $ PAtom b (elab $ EApp (unElab e1) e) (elab $ EApp (unElab e2) e) -instantiate :: [DataDecl] -> Sort -> Ex [Expr] -instantiate ds s = instantiateOne (breakSort ds s) +instantiate :: a -> [DataDecl] -> Sort -> Ex a [Expr] +instantiate ann ds s = instantiateOne ann (breakSort ds s) -instantiateOne :: Either [(LocSymbol, [Sort])] Sort -> Ex [Expr] -instantiateOne (Right s@(FVar _)) = - (\x -> [EVar x]) <$> freshArgOne s -instantiateOne (Right s) = do - xss <- excbs <$> get - return [EVar x | (x,xs) <- xss, xs == s ] -instantiateOne (Left [(dc, ts)]) = - (map (mkEApp dc) . combine) <$> mapM instantiateOne (Right <$> ts) -instantiateOne _ = undefined +instantiateOne :: a -> Either [(LocSymbol, [Sort])] Sort -> Ex a [Expr] +instantiateOne ann (Right s@(FVar _)) = + (\x -> [EVar x]) <$> freshArgOne ann s +instantiateOne _ (Right s) = do + xss <- gets excbs + return [EVar x | (x,xs) <- xss, xs == s ] +instantiateOne ann (Left [(dc, ts)]) = + map (mkEApp dc) . combine <$> mapM (instantiateOne ann) (Right <$> ts) +instantiateOne _ _ = undefined combine :: [[a]] -> [[a]] combine [] = [[]] @@ -118,45 +123,45 @@ combine ((x:xs):ys) = map (x:) (combine ys) ++ combine (xs:ys) -data Pos = Pos | Neg deriving Eq -negatePos :: Pos -> Pos -negatePos Pos = Neg -negatePos Neg = Pos +data Pos = Pos | Neg deriving Eq +negatePos :: Pos -> Pos +negatePos Pos = Neg +negatePos Neg = Pos mapMPosExpr :: (Monad m) => Pos -> (Pos -> Expr -> m Expr) -> Expr -> m Expr -mapMPosExpr p f = go p +mapMPosExpr p f = go p where go p e@(ESym _) = f p e go p e@(ECon _) = f p e go p e@(EVar _) = f p e go p e@(PKVar _ _) = f p e - go p (ENeg e) = f p =<< (ENeg <$> go p e ) - go p (ECst e t) = f p =<< ((`ECst` t) <$> go p e ) - go p (ECoerc a t e) = f p =<< (ECoerc a t <$> go p e ) + go p (ENeg e) = f p . ENeg =<< go p e + go p (ECst e t) = f p . (`ECst` t) =<< go p e + go p (ECoerc a t e) = f p . ECoerc a t =<< go p e go p (EApp g e) = f p =<< (EApp <$> go p g <*> go p e ) go p (EBin o e1 e2) = f p =<< (EBin o <$> go p e1 <*> go p e2 ) go p (PAtom r e1 e2) = f p =<< (PAtom r <$> go p e1 <*> go p e2 ) go p (PImp p1 p2) = f p =<< (PImp <$> go (negatePos p) p1 <*> go p p2) - go p (PAnd ps) = f p =<< (PAnd <$> (go p <$$> ps) ) + go p (PAnd ps) = f p . PAnd =<< (go p `traverse` ps) -- The below cannot appear due to normalization - go p (PNot e) = f p =<< (PNot <$> go p e ) + go p (PNot e) = f p . PNot =<< go p e go p (PIff p1 p2) = f p =<< (PIff <$> go p p1 <*> go p p2 ) go p (EIte e e1 e2) = f p =<< (EIte <$> go p e <*> go p e1 <*> go p e2) - go p (POr ps) = f p =<< (POr <$> (go p <$$> ps) ) + go p (POr ps) = f p . POr =<< (go p `traverse` ps) - -- The following canot appear in general - go p (PAll xts e) = f p =<< (PAll xts <$> go p e ) - go p (ELam (x,t) e) = f p =<< (ELam (x,t) <$> go p e ) - go p (PExist xts e) = f p =<< (PExist xts <$> go p e ) - go p (ETApp e s) = f p =<< ((`ETApp` s) <$> go p e ) - go p (ETAbs e s) = f p =<< ((`ETAbs` s) <$> go p e ) - go p (PGrad k s i e) = f p =<< (PGrad k s i <$> go p e ) + -- The following canot appear in general + go p (PAll xts e) = f p . PAll xts =<< go p e + go p (ELam (x,t) e) = f p . ELam (x,t) =<< go p e + go p (PExist xts e) = f p . PExist xts =<< go p e + go p (ETApp e s) = f p . (`ETApp` s) =<< go p e + go p (ETAbs e s) = f p . (`ETAbs` s) =<< go p e + go p (PGrad k s i e) = f p . PGrad k s i =<< go p e -normalize :: Expr -> Expr -normalize e = mytracepp ("normalize: " ++ showpp e) $ go e - where +normalize :: Expr -> Expr +normalize e = mytracepp ("normalize: " ++ showpp e) $ go e + where go e@(ESym _) = e go e@(ECon _) = e go e@(EVar _) = e @@ -164,35 +169,36 @@ go e@(ENeg _) = e go (PNot e) = PImp e PFalse go e@(ECst _ _) = e - go e@(ECoerc _ _ _) = e - go e@(EApp _ _) = e - go e@(EBin _ _ _) = e + go e@ECoerc{} = e + go e@(EApp _ _) = e + go e@EBin{} = e go (PImp p1 p2) = PImp (go p1) (go p2) go (PIff p1 p2) = PAnd [PImp p1' p2', PImp p2' p1'] where (p1', p2') = (go p1, go p2) - go e@(PAtom _ _ _) = e + go e@PAtom{} = e go (EIte e e1 e2) = go $ PAnd [PImp e e1, PImp (PNot e) e2] go (PAnd ps) = pAnd (go <$> ps) - go (POr ps) = foldl (\x y -> PImp (PImp (go x) PFalse) y) PFalse ps + go (POr ps) = foldl' (\x y -> PImp (PImp (go x) PFalse) y) PFalse ps go e@(PAll _ _) = e -- Cannot appear go e@(ELam _ _) = e -- Cannot appear go e@(PExist _ _) = e -- Cannot appear go e@(ETApp _ _) = e -- Cannot appear go e@(ETAbs _ _) = e -- Cannot appear - go e@(PGrad _ _ _ _) = e -- Cannot appear + go e@PGrad{} = e -- Cannot appear - -type Ex = State ExSt -data ExSt = ExSt { unique :: Int - , exddecl :: [DataDecl] - , exenv :: SymEnv -- used for elaboration - , exbenv :: BindEnv - , exbinds :: IBindEnv - , excbs :: [(Symbol, Sort)] - } -initST :: SymEnv -> [DataDecl] -> ExSt +type Ex a = State (ExSt a) +data ExSt a = ExSt + { unique :: Int + , exddecl :: [DataDecl] + , exenv :: SymEnv -- used for elaboration + , exbenv :: BindEnv a + , exbinds :: IBindEnv + , excbs :: [(Symbol, Sort)] + } + +initST :: SymEnv -> [DataDecl] -> ExSt ann initST env dd = ExSt 0 (d:dd) env mempty mempty mempty - where + where -- NV: hardcore Haskell pairs because they do not appear in DataDecl (why?) d = mytracepp "Tuple DataDecl" $ DDecl (symbolFTycon (dummyLoc tupConName)) 2 [ct] ct = DCtor (dummyLoc (symbol "GHC.Tuple.(,)")) [ @@ -201,58 +207,58 @@ ] -setBEnv :: BindEnv -> Ex () +setBEnv :: BindEnv a -> Ex a () setBEnv benv = modify (\st -> st{exbenv = benv}) -setExBinds :: IBindEnv-> Ex () +setExBinds :: IBindEnv -> Ex a () setExBinds bids = modify (\st -> st{ exbinds = bids - , excbs = [ (x, sr_sort r) | (i, x, r) <- bindEnvToList (exbenv st) + , excbs = [ (x, sr_sort r) | (i, (x, r, _)) <- bindEnvToList (exbenv st) , memberIBindEnv i bids]}) -freshArgDD :: (LocSymbol, [Sort]) -> Ex Expr -freshArgDD (dc, xs) = do - xs <- mapM freshArgOne xs +freshArgDD :: a -> (LocSymbol, [Sort]) -> Ex a Expr +freshArgDD ann (dc, xs) = do + xs <- mapM (freshArgOne ann) xs return $ mkEApp dc (EVar <$> xs) -freshArgOne :: Sort -> Ex Symbol -freshArgOne s = do - st <- get +freshArgOne :: ann -> Sort -> Ex ann Symbol +freshArgOne ann s = do + st <- get let x = symbol ("ext$" ++ show (unique st)) - let (id, benv') = insertBindEnv x (trueSortedReft s) (exbenv st) + let (id, benv') = insertBindEnv x (trueSortedReft s) ann (exbenv st) modify (\st -> st{ exenv = insertSymEnv x s (exenv st) , exbenv = benv' , exbinds = insertsIBindEnv [id] (exbinds st) - , unique = 1 + (unique st) - , excbs = (x,s):(excbs st) + , unique = 1 + unique st + , excbs = (x,s) : excbs st }) - return x + return x -breakSort :: [DataDecl] -> Sort -> Either [(LocSymbol, [Sort])] Sort +breakSort :: [DataDecl] -> Sort -> Either [(LocSymbol, [Sort])] Sort breakSort ddecls s | Just (tc, ts) <- splitTC s - , [(dds,i)] <- [ (ddCtors dd,ddVars dd) | dd <- ddecls, ddTyCon dd == tc ] - = Left ((\dd -> (dcName dd, (instSort (Sub $ zip [0..(i-1)] ts)) <$> dfSort <$> dcFields dd)) <$> dds) - | otherwise + , [(dds,i)] <- [ (ddCtors dd,ddVars dd) | dd <- ddecls, ddTyCon dd == tc ] + = Left ((\dd -> (dcName dd, instSort (Sub $ zip [0..(i-1)] ts) . dfSort <$> dcFields dd)) <$> dds) + | otherwise = Right s -instSort :: Sub -> Sort -> Sort -instSort (Sub su) x = mapSort go x - where - go :: Sort -> Sort - go (FVar i) = fromMaybe (FVar i) $ lookup i su - go s = s - +instSort :: Sub -> Sort -> Sort +instSort (Sub su) x = mapSort go x + where + go :: Sort -> Sort + go (FVar i) = fromMaybe (FVar i) $ lookup i su + go s = s + splitTC :: Sort -> Maybe (FTycon, [Sort]) -splitTC s - | (FTC f, ts) <- splitFApp s +splitTC s + | (FTC f, ts) <- splitFApp s = Just (f, ts) | otherwise - = Nothing + = Nothing splitFApp :: Sort -> (Sort, [Sort]) -splitFApp = go [] - where go acc (FApp s1 s2) = go (s2:acc) s1 +splitFApp = go [] + where go acc (FApp s1 s2) = go (s2:acc) s1 go acc s = (s, acc) diff --git a/src/Language/Fixpoint/Solver/GradualSolution.hs b/src/Language/Fixpoint/Solver/GradualSolution.hs --- a/src/Language/Fixpoint/Solver/GradualSolution.hs +++ b/src/Language/Fixpoint/Solver/GradualSolution.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver.GradualSolution ( -- * Create Initial Solution init @@ -11,9 +12,6 @@ import qualified Data.HashMap.Strict as M import qualified Data.List as L import Data.Maybe (maybeToList, isNothing) -#if !MIN_VERSION_base(4,14,0) -import Data.Monoid ((<>)) -#endif import Language.Fixpoint.Types.Config import Language.Fixpoint.Types.PrettyPrint () import qualified Language.Fixpoint.SortCheck as So @@ -30,7 +28,7 @@ -------------------------------------------------------------------------------- init :: (F.Fixpoint a) => Config -> F.SInfo a -> [(F.KVar, (F.GWInfo, [F.Expr]))] -------------------------------------------------------------------------------- -init cfg si = map (elab . refineG si qs genv) gs `using` parList rdeepseq +init cfg si = map (elab . refineG si qs genv) gs `using` parList rdeepseq where qs = F.quals si gs = snd <$> gs0 @@ -38,8 +36,8 @@ gs0 = L.filter (isGWfc . snd) $ M.toList (F.ws si) - elab (k,(x,es)) = ((k,) . (x,)) $ (elaborate (F.atLoc F.dummySpan "init") (sEnv (gsym x) (gsort x)) <$> es) - + elab (k, (x,es)) = (k, (x, elaborate (F.atLoc F.dummySpan "init") (sEnv (gsym x) (gsort x)) <$> es)) + sEnv x s = isEnv {F.seSort = F.insertSEnv x s (F.seSort isEnv)} isEnv = symbolEnv cfg si @@ -47,8 +45,8 @@ -------------------------------------------------------------------------------- refineG :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> (F.KVar, (F.GWInfo, [F.Expr])) refineG fi qs genv w = (k, (F.gwInfo w, Sol.qbExprs qb)) - where - (k, qb) = refine fi qs genv w + where + (k, qb) = refine fi qs genv w refine :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> (F.KVar, Sol.QBind) refine fi qs genv w = refineK (allowHOquals fi) env qs $ F.wrft w @@ -86,14 +84,16 @@ -> F.Sort -> F.Qualifier -> [Sol.EQual] -instKQ ho env v t q - = do (su0, v0) <- candidates senv [(t, [v])] qt - xs <- match senv tyss [v0] (So.apply su0 <$> qts) - return $ Sol.eQual q (reverse xs) - where - qt : qts = qpSort <$> F.qParams q - tyss = instCands ho env - senv = (`F.lookupSEnvWithDistance` env) +instKQ ho env v t q = + case qpSort <$> F.qParams q of + (qt:qts) -> do + (su0, v0) <- candidates senv [(t, [v])] qt + xs <- match senv tyss [v0] (So.apply su0 <$> qts) + return $ Sol.eQual q (reverse xs) + where + tyss = instCands ho env + senv = (`F.lookupSEnvWithDistance` env) + [] -> error "Empty qpSort of qParams q" instCands :: Bool -> F.SEnv F.Sort -> [(F.Sort, [F.Symbol])] instCands ho env = filter isOk tyss @@ -112,7 +112,7 @@ -------------------------------------------------------------------------------- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.Sort -> [(So.TVSubst, F.Symbol)] -------------------------------------------------------------------------------- -candidates env tyss tx = +candidates env tyss tx = [(su, y) | (t, ys) <- tyss , su <- maybeToList $ So.unifyFast mono env tx t , y <- ys ] @@ -126,6 +126,6 @@ where sr = F.RR t (F.Reft (v, p)) p = Sol.eqPred eq - tc = So.checkSorted F.dummySpan env sr + tc = So.checkSorted F.dummySpan env sr diff --git a/src/Language/Fixpoint/Solver/GradualSolve.hs b/src/Language/Fixpoint/Solver/GradualSolve.hs --- a/src/Language/Fixpoint/Solver/GradualSolve.hs +++ b/src/Language/Fixpoint/Solver/GradualSolve.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | Solve a system of horn-clause constraints --------------------------------- diff --git a/src/Language/Fixpoint/Solver/Instantiate.hs b/src/Language/Fixpoint/Solver/Instantiate.hs --- a/src/Language/Fixpoint/Solver/Instantiate.hs +++ b/src/Language/Fixpoint/Solver/Instantiate.hs @@ -1,23 +1,24 @@ -------------------------------------------------------------------------------- --- | This module implements "Proof by Logical Evaluation" where we +-- | This module implements "Proof by Logical Evaluation" where we -- unfold function definitions if they *must* be unfolded, to strengthen --- the environments with function-definition-equalities. +-- the environments with function-definition-equalities. -- The algorithm is discussed at length in: --- +-- -- 1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842 --- 2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf +-- 2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver.Instantiate (instantiate) where import Language.Fixpoint.Types @@ -26,12 +27,14 @@ import qualified Language.Fixpoint.Misc as Misc -- (mapFst) import qualified Language.Fixpoint.Smt.Interface as SMT import Language.Fixpoint.Defunctionalize -import qualified Language.Fixpoint.Utils.Trie as T -import Language.Fixpoint.Utils.Progress -- as T +import qualified Language.Fixpoint.Utils.Trie as T +import Language.Fixpoint.Utils.Progress -- as T import Language.Fixpoint.SortCheck -import Language.Fixpoint.Graph.Deps (isTarget) +import Language.Fixpoint.Graph.Deps (isTarget) import Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Solver.PLE as PLE (instantiate) +import qualified Language.Fixpoint.Solver.Common as Common (toSMT) +import Language.Fixpoint.Solver.Common (askSMT) import Control.Monad.State import Data.Bifunctor (second) import qualified Data.Text as T @@ -44,10 +47,10 @@ -- import Text.Printf (printf) mytracepp :: (PPrint a) => String -> a -> a -mytracepp = notracepp +mytracepp = notracepp -------------------------------------------------------------------------------- --- | Strengthen Constraint Environments via PLE +-- | Strengthen Constraint Environments via PLE -------------------------------------------------------------------------------- instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) instantiate cfg fi subcIds @@ -61,154 +64,154 @@ = incrInstantiate' cfg fi subcIds -------------------------------------------------------------------------------- --- | New "Incremental" PLE -- see [NOTE:TREE-LIKE] +------------------------------------------------------------------------------- +-- | New "Incremental" PLE -- see [NOTE:TREE-LIKE] -{- | [NOTE:TREE-LIKE] incremental PLE relies crucially on the SInfo satisfying - a "tree like" invariant: - forall constraints c, c'. - if i in c and i in c' then +{- | [NOTE:TREE-LIKE] incremental PLE relies crucially on the SInfo satisfying + a "tree like" invariant: + forall constraints c, c'. + if i in c and i in c' then forall 0 <= j < i, j in c and j in c' -} -------------------------------------------------------------------------------- +------------------------------------------------------------------------------- incrInstantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) -------------------------------------------------------------------------------- +------------------------------------------------------------------------------- incrInstantiate' cfg fi subcIds = do let cs = [ (i, c) | (i, c) <- M.toList (cm fi), isPleCstr aEnv i c , maybe True (i `L.elem`) subcIds ] let t = mkCTrie cs -- 1. BUILD the Trie - res <- withProgress (1 + length cs) $ + res <- withProgress (1 + length cs) $ withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs) -- 2. TRAVERSE Trie to compute InstRes return $ resSInfo cfg sEnv fi res -- 3. STRENGTHEN SInfo using InstRes where file = srcFile cfg ++ ".evals" sEnv = symbolEnv cfg fi - aEnv = ae fi + aEnv = ae fi -------------------------------------------------------------------------------- --- | Step 1a: @instEnv@ sets up the incremental-PLE environment -instEnv :: (Loc a) => Config -> SInfo a -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a +------------------------------------------------------------------------------- +-- | Step 1a: @instEnv@ sets up the incremental-PLE environment +instEnv :: (Loc a) => Config -> SInfo a -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a instEnv cfg fi cs ctx = InstEnv cfg ctx bEnv aEnv (M.fromList cs) γ s0 - where + where bEnv = bs fi aEnv = ae fi - γ = knowledge cfg ctx aEnv - s0 = EvalEnv 0 [] aEnv (SMT.ctxSymEnv ctx) cfg + γ = knowledge cfg ctx aEnv + s0 = EvalEnv 0 [] aEnv (SMT.ctxSymEnv ctx) cfg ----------------------------------------------------------------------------------------------- --- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments -mkCTrie :: [(SubcId, SimpC a)] -> CTrie +---------------------------------------------------------------------------------------------- +-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments +mkCTrie :: [(SubcId, SimpC a)] -> CTrie mkCTrie ics = mytracepp "TRIE" $ T.fromList [ (cBinds c, i) | (i, c) <- ics ] where - cBinds = L.sort . elemsIBindEnv . senv + cBinds = L.sort . elemsIBindEnv . senv ----------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------- -- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE pleTrie :: CTrie -> InstEnv a -> IO InstRes -pleTrie t env = loopT env ctx0 diff0 Nothing res0 t - where +pleTrie t env = loopT env ctx0 diff0 Nothing res0 t + where diff0 = [] - res0 = M.empty + res0 = M.empty ctx0 = initCtx es0 es0 = eqBody <$> L.filter (null . eqArgs) (aenvEqs . ieAenv $ env) loopT :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CTrie -> IO InstRes -loopT env ctx delta i res t = case t of +loopT env ctx delta i res t = case t of T.Node [] -> return res T.Node [b] -> loopB env ctx delta i res b - T.Node bs -> withAssms env ctx delta Nothing $ \ctx' -> do - (ctx'', res') <- ple1 env ctx' i Nothing res + T.Node bs -> withAssms env ctx delta Nothing $ \ctx' -> do + (ctx'', res') <- ple1 env ctx' i Nothing res foldM (loopB env ctx'' [] i) res' bs loopB :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CBranch -> IO InstRes -loopB env ctx delta iMb res b = case b of +loopB env ctx delta iMb res b = case b of T.Bind i t -> loopT env ctx (i:delta) (Just i) res t - T.Val cid -> withAssms env ctx delta (Just cid) $ \ctx' -> do + T.Val cid -> withAssms env ctx delta (Just cid) $ \ctx' -> do progressTick - (snd <$> ple1 env ctx' iMb (Just cid) res) + snd <$> ple1 env ctx' iMb (Just cid) res -withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b -withAssms env@(InstEnv {..}) ctx delta cidMb act = do - let ctx' = updCtx env ctx delta cidMb +withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b +withAssms env@InstEnv{..} ctx delta cidMb act = do + let ctx' = updCtx env ctx delta cidMb let assms = mytracepp ("ple1-assms: " ++ show (cidMb, delta)) (icAssms ctx') SMT.smtBracket ieSMT "PLE.evaluate" $ do - forM_ assms (SMT.smtAssert ieSMT) + forM_ assms (SMT.smtAssert ieSMT) act ctx' --- | @ple1@ performs the PLE at a single "node" in the Trie +-- | @ple1@ performs the PLE at a single "node" in the Trie ple1 :: InstEnv a -> ICtx -> Maybe BindId -> Maybe SubcId -> InstRes -> IO (ICtx, InstRes) -ple1 env@(InstEnv {..}) ctx i cidMb res = do - let cands = mytracepp ("ple1-cands: " ++ show cidMb) $ S.toList (icCands ctx) - -- unfolds <- evalCands ieKnowl ieEvEnv cands - unfolds <- evalCandsLoop ieCfg ieSMT ieKnowl ieEvEnv cands +ple1 env@InstEnv{..} ctx i cidMb res = do + let cands = mytracepp ("ple1-cands: " ++ show cidMb) $ S.toList (icCands ctx) + -- unfolds <- evalCands ieKnowl ieEvEnv cands + unfolds <- evalCandsLoop ieCfg ieSMT ieKnowl ieEvEnv cands return $ updCtxRes env ctx res i cidMb (mytracepp ("ple1-cands-unfolds: " ++ show cidMb) unfolds) -_evalCands :: Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] +_evalCands :: Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] _evalCands _ _ [] = return [] _evalCands γ s0 cands = do eqs <- mapM (evalOne γ s0) cands return $ mkUnfolds (zip (Just <$> cands) eqs) -unfoldPred :: Config -> SMT.Context -> [Unfold] -> Pred -unfoldPred cfg ctx = toSMT cfg ctx [] . pAnd . concatMap snd +unfoldPred :: Config -> SMT.Context -> [Unfold] -> Pred +unfoldPred cfg ctx = toSMT cfg ctx [] . pAnd . concatMap snd -evalCandsLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] -evalCandsLoop cfg ctx γ s0 cands = go [] cands - where - go acc [] = return acc +evalCandsLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] +evalCandsLoop cfg ctx γ s0 cands = go [] cands + where + go acc [] = return acc go acc cands = do eqss <- SMT.smtBracket ctx "PLE.evaluate" $ do - SMT.smtAssert ctx (unfoldPred cfg ctx acc) + SMT.smtAssert ctx (unfoldPred cfg ctx acc) mapM (evalOne γ s0) cands - let us = zip (Just <$> cands) eqss - case mkUnfolds us of - [] -> return acc - us' -> do let acc' = acc ++ us' + let us = zip (Just <$> cands) eqss + case mkUnfolds us of + [] -> return acc + us' -> do let acc' = acc ++ us' let oks = S.fromList [ e | (Just e, _) <- us' ] - let cands' = [ e | e <- cands, not (S.member e oks) ] - go acc' cands' + let cands' = [ e | e <- cands, not (S.member e oks) ] + go acc' cands' ----------------------------------------------------------------------------------------------- --- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo +---------------------------------------------------------------------------------------------- +-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a -resSInfo cfg env fi res = strengthenBinds fi res' +resSInfo cfg env fi res = strengthenBinds fi res' where res' = M.fromList $ mytracepp "ELAB-INST: " $ zip is ps'' - ps'' = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' + ps'' = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' ps' = defuncAny cfg env ps (is, ps) = unzip (M.toList res) ----------------------------------------------------------------------------------------------- +---------------------------------------------------------------------------------------------- -- | @InstEnv@ has the global information needed to do PLE -data InstEnv a = InstEnv +data InstEnv a = InstEnv { ieCfg :: !Config , ieSMT :: !SMT.Context - , ieBEnv :: !BindEnv - , ieAenv :: !AxiomEnv + , ieBEnv :: !(BindEnv a) + , ieAenv :: !AxiomEnv , ieCstrs :: !(M.HashMap SubcId (SimpC a)) , ieKnowl :: !Knowledge , ieEvEnv :: !EvalEnv - } + } -- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE -data ICtx = ICtx - { icAssms :: ![Pred] -- ^ Hypotheses, already converted to SMT format +data ICtx = ICtx + { icAssms :: ![Pred] -- ^ Hypotheses, already converted to SMT format , icCands :: S.HashSet Expr -- ^ "Candidates" for unfolding , icEquals :: ![Expr] -- ^ "Known" equalities , icSolved :: S.HashSet Expr -- ^ Terms that we have already expanded - } + } -- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId type InstRes = M.HashMap BindId Expr --- | @Unfold is the result of running PLE at a single equality; --- (e, [(e1, e1')...]) is the source @e@ and the (possible empty) --- list of PLE-generated equalities (e1, e1') ... +-- | @Unfold is the result of running PLE at a single equality; +-- (e, [(e1, e1')...]) is the source @e@ and the (possible empty) +-- list of PLE-generated equalities (e1, e1') ... -- type Unfold = (Maybe Expr, [(Expr, Expr)]) type Unfold = (Maybe Expr, [Expr]) type CTrie = T.Trie SubcId @@ -216,32 +219,32 @@ type Diff = [BindId] -- ^ in "reverse" order initCtx :: [Expr] -> ICtx -initCtx es = ICtx - { icAssms = [] - , icCands = mempty - , icEquals = mytracepp "INITIAL-STUFF-INCR" es +initCtx es = ICtx + { icAssms = [] + , icCands = mempty + , icEquals = mytracepp "INITIAL-STUFF-INCR" es , icSolved = mempty } equalitiesPred :: [(Expr, Expr)] -> [Expr] -equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ] +equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ] -updCtxRes :: InstEnv a -> ICtx -> InstRes -> Maybe BindId -> Maybe SubcId -> [Unfold] -> (ICtx, InstRes) -updCtxRes env ctx res iMb cidMb us - = -- trace _msg +updCtxRes :: InstEnv a -> ICtx -> InstRes -> Maybe BindId -> Maybe SubcId -> [Unfold] -> (ICtx, InstRes) +updCtxRes env ctx res iMb cidMb us + = -- trace _msg ( ctx { {- icCands = cands', -} icSolved = solved', icEquals = mempty} , res' - ) - where + ) + where _msg = Mb.maybe "nuttin\n" (debugResult env res') cidMb - res' = updRes res iMb (pAnd solvedEqs) - _cands' = ((icCands ctx) `S.union` newCands) `S.difference` solved' - solved' = S.union (icSolved ctx) solvedCands - newCands = S.fromList (concatMap topApps newEqs) - solvedCands = S.fromList [ e | (Just e, _) <- okUnfolds ] - solvedEqs = icEquals ctx ++ newEqs + res' = updRes res iMb (pAnd solvedEqs) + _cands' = (icCands ctx `S.union` newCands) `S.difference` solved' + solved' = S.union (icSolved ctx) solvedCands + newCands = S.fromList (concatMap topApps newEqs) + solvedCands = S.fromList [ e | (Just e, _) <- okUnfolds ] + solvedEqs = icEquals ctx ++ newEqs newEqs = concatMap snd okUnfolds - okUnfolds = mytracepp _str [ (eMb, ps) | (eMb, ps) <- us, {- let ps = equalitiesPred eqs, -} not (null ps) ] + okUnfolds = mytracepp _str [ (eMb, ps) | (eMb, ps) <- us, {- let ps = equalitiesPred eqs, -} not (null ps) ] _str = "okUnfolds " ++ showpp (iMb, cidMb) -- cands' = S.difference (icCands ctx) (S.fromList solvedCands) -- solvedEqs = icEquals ctx ++ concatMap snd us @@ -250,46 +253,48 @@ mkUnfolds :: [(a, [(Expr, Expr)])] -> [(a, [Expr])] mkUnfolds us = [ (eMb, ps) | (eMb, eqs) <- us , let ps = equalitiesPred eqs - , not (null ps) - ] + , not (null ps) + ] -debugResult :: InstEnv a -> InstRes -> SubcId -> String -debugResult (InstEnv {..}) res i = msg - where - msg = "INCR-INSTANTIATE i = " ++ show i ++ ": " ++ showpp cidEqs - cidEqs = pAnd [ e | i <- cBinds, e <- Mb.maybeToList $ M.lookup i res ] +debugResult :: InstEnv a -> InstRes -> SubcId -> String +debugResult InstEnv{..} res i = msg + where + msg = "INCR-INSTANTIATE i = " ++ show i ++ ": " ++ showpp cidEqs + cidEqs = pAnd [ e | i <- cBinds, e <- Mb.maybeToList $ M.lookup i res ] cBinds = L.sort . elemsIBindEnv . senv . getCstr ieCstrs $ i updRes :: InstRes -> Maybe BindId -> Expr -> InstRes -updRes res (Just i) e = M.insert i e res -updRes res Nothing _ = res +updRes res (Just i) e = M.insert i e res +updRes res Nothing _ = res --- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ --- to the context. -updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx -updCtx InstEnv {..} ctx delta cidMb - = ctx { icAssms = ctxEqs +-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ +-- to the context. +updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx +updCtx InstEnv {..} ctx delta cidMb + = ctx { icAssms = ctxEqs , icCands = cands <> icCands ctx , icEquals = initEqs <> icEquals ctx } - where + where initEqs = equalitiesPred (initEqualities ieSMT ieAenv bs) - cands = (S.fromList (concatMap topApps es0)) `S.difference` (icSolved ctx) - ctxEqs = toSMT ieCfg ieSMT [] <$> concat - [ initEqs - , [ expr xr | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ] - ] + cands = S.fromList (concatMap topApps es0) `S.difference` icSolved ctx + ctxEqs = toSMT ieCfg ieSMT [] <$> + (initEqs ++ + [ expr xr + | xr@(_, r) <- bs + , null (Vis.kvarsExpr $ reftPred $ sr_reft r) + ]) (bs, es0) = (second unElabSortedReft <$> binds, unElab <$> es) - es = eRhs : (expr <$> binds) + es = eRhs : (expr <$> binds) eRhs = maybe PTrue crhs subMb - binds = [ lookupBindEnv i ieBEnv | i <- delta ] + binds = [ (x, y) | i <- delta, let (x, y, _) = lookupBindEnv i ieBEnv ] subMb = getCstr ieCstrs <$> cidMb -getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a +getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env -------------------------------------------------------------------------------- --- | "Old" GLOBAL PLE +-- | "Old" GLOBAL PLE -------------------------------------------------------------------------------- instantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) instantiate' cfg fi subcIds = sInfo cfg env fi <$> withCtx cfg file env act @@ -300,69 +305,69 @@ , maybe True (i `L.elem`) subcIds ] file = srcFile cfg ++ ".evals" env = symbolEnv cfg fi - aenv = {- mytracepp "AXIOM-ENV" -} (ae fi) + aenv = {- mytracepp "AXIOM-ENV" -} ae fi sInfo :: Config -> SymEnv -> SInfo a -> [((SubcId, SrcSpan), Expr)] -> SInfo a sInfo cfg env fi ips = strengthenHyp fi (mytracepp "ELAB-INST: " $ zip (fst <$> is) ps'') where (is, ps) = unzip ips ps' = defuncAny cfg env ps - ps'' = zipWith (\(i, sp) -> elaborate (atLoc sp ("PLE1 " ++ show i)) env) is ps' + ps'' = zipWith (\(i, sp) -> elaborate (atLoc sp ("PLE1 " ++ show i)) env) is ps' -instSimpC :: Config -> SMT.Context -> BindEnv -> AxiomEnv -> SubcId -> SimpC a -> IO Expr -instSimpC cfg ctx bds aenv sid sub +instSimpC :: Config -> SMT.Context -> BindEnv a -> AxiomEnv -> SubcId -> SimpC a -> IO Expr +instSimpC cfg ctx bds aenv sid sub | isPleCstr aenv sid sub = do - let is0 = mytracepp "INITIAL-STUFF" $ eqBody <$> L.filter (null . eqArgs) (aenvEqs aenv) + let is0 = mytracepp "INITIAL-STUFF" $ eqBody <$> L.filter (null . eqArgs) (aenvEqs aenv) let (bs, es0) = cstrExprs bds sub - equalities <- evaluate cfg ctx aenv bs es0 sid - let evalEqs = [ EEq e1 e2 | (e1, e2) <- equalities, e1 /= e2 ] - return $ pAnd (is0 ++ evalEqs) + equalities <- evaluate cfg ctx aenv bs es0 sid + let evalEqs = [ EEq e1 e2 | (e1, e2) <- equalities, e1 /= e2 ] + return $ pAnd (is0 ++ evalEqs) | otherwise = return PTrue isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool -isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) +isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) -cstrExprs :: BindEnv -> SimpC a -> ([(Symbol, SortedReft)], [Expr]) +cstrExprs :: BindEnv a -> SimpC a -> ([(Symbol, SortedReft)], [Expr]) cstrExprs bds sub = (second unElabSortedReft <$> binds, unElab <$> es) where - es = (crhs sub) : (expr <$> binds) + es = crhs sub : (expr <$> binds) binds = envCs bds (senv sub) -------------------------------------------------------------------------------- -- | Symbolic Evaluation with SMT -------------------------------------------------------------------------------- evaluate :: Config -> SMT.Context -> AxiomEnv -- ^ Definitions - -> [(Symbol, SortedReft)] -- ^ Environment of "true" facts - -> [Expr] -- ^ Candidates for unfolding + -> [(Symbol, SortedReft)] -- ^ Environment of "true" facts + -> [Expr] -- ^ Candidates for unfolding -> SubcId -- ^ Constraint Id -> IO [(Expr, Expr)] -- ^ Newly unfolded equalities -------------------------------------------------------------------------------- -evaluate cfg ctx aenv facts es sid = do - let eqs = initEqualities ctx aenv facts - let γ = knowledge cfg ctx aenv +evaluate cfg ctx aenv facts es sid = do + let eqs = initEqualities ctx aenv facts + let γ = knowledge cfg ctx aenv let cands = mytracepp ("evaluate-cands " ++ showpp sid) $ Misc.hashNub (concatMap topApps es) let s0 = EvalEnv 0 [] aenv (SMT.ctxSymEnv ctx) cfg let ctxEqs = [ toSMT cfg ctx [] (EEq e1 e2) | (e1, e2) <- eqs ] ++ [ toSMT cfg ctx [] (expr xr) | xr@(_, r) <- facts, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ] - eqss <- _evalLoop cfg ctx γ s0 ctxEqs cands + eqss <- _evalLoop cfg ctx γ s0 ctxEqs cands return $ eqs ++ eqss - + _evalLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Pred] -> [Expr] -> IO [(Expr, Expr)] -_evalLoop cfg ctx γ s0 ctxEqs cands = loop 0 [] cands - where +_evalLoop cfg ctx γ s0 ctxEqs cands = loop 0 [] cands + where loop _ acc [] = return acc loop i acc cands = do let eqp = toSMT cfg ctx [] $ pAnd $ equalitiesPred acc eqss <- SMT.smtBracket ctx "PLE.evaluate" $ do - forM_ (eqp : ctxEqs) (SMT.smtAssert ctx) + forM_ (eqp : ctxEqs) (SMT.smtAssert ctx) mapM (evalOne γ s0) cands - case concat eqss of - [] -> return acc - eqs' -> do let acc' = acc ++ eqs' + case concat eqss of + [] -> return acc + eqs' -> do let acc' = acc ++ eqs' let oks = S.fromList (fst <$> eqs') - let cands' = [ e | e <- cands, not (S.member e oks) ] - loop (i+1) acc' cands' + let cands' = [ e | e <- cands, not (S.member e oks) ] + loop (i + 1 :: Integer) acc' cands' @@ -380,41 +385,41 @@ evalOne :: Knowledge -> EvalEnv -> Expr -> IO [(Expr, Expr)] evalOne γ s0 e = do - (e', st) <- runStateT (eval γ initCS (mytracepp "evalOne: " e)) s0 + (e', st) <- runStateT (eval γ initCS (mytracepp "evalOne: " e)) s0 if e' == e then return [] else return ((e, e') : evSequence st) -{- | [NOTE: Eval-Ite] We should not be doing any PLE/eval under if-then-else where +{- | [NOTE: Eval-Ite] We should not be doing any PLE/eval under if-then-else where the guard condition does not provably hold. For example, see issue #387. - However, its ok and desirable to `eval` in this case, as long as one is not - unfolding recursive functions. To permit this, we track the "call-stack" and - whether or not, `eval` is occurring under an unresolved guard: if so, we do not + However, its ok and desirable to `eval` in this case, as long as one is not + unfolding recursive functions. To permit this, we track the "call-stack" and + whether or not, `eval` is occurring under an unresolved guard: if so, we do not expand under any function that is already on the call-stack. -} data Recur = Ok | Stop deriving (Eq, Show) type CStack = ([Symbol], Recur) -instance PPrint Recur where - pprintTidy _ = Misc.tshow +instance PPrint Recur where + pprintTidy _ = Misc.tshow -initCS :: CStack +initCS :: CStack initCS = ([], Ok) -pushCS :: CStack -> Symbol -> CStack +pushCS :: CStack -> Symbol -> CStack pushCS (fs, r) f = (f:fs, r) -recurCS :: CStack -> Symbol -> Bool -recurCS (_, Ok) _ = True --- recurCS (_, _ ) _ = False -- not (f `elem` fs) -recurCS (fs, _) f = not (f `elem` fs) +recurCS :: CStack -> Symbol -> Bool +recurCS (_, Ok) _ = True +-- recurCS (_, _ ) _ = False -- not (f `elem` fs) +recurCS (fs, _) f = f `notElem` fs -noRecurCS :: CStack -> CStack +noRecurCS :: CStack -> CStack noRecurCS (fs, _) = (fs, Stop) -- Don't evaluate under Lam, App, Ite, or Constants topApps :: Expr -> [Expr] -topApps = go - where +topApps = go + where go (PAnd es) = concatMap go es go (POr es) = concatMap go es go (PAtom _ e1 e2) = go e1 ++ go e2 @@ -431,12 +436,12 @@ makeLam γ e = L.foldl' (flip ELam) e (knLams γ) eval :: Knowledge -> CStack -> Expr -> EvalST Expr -eval γ stk = go - where +eval γ stk = go + where go (ELam (x,s) e) = ELam (x, s) <$> eval γ' stk e where γ' = γ { knLams = (x, s) : knLams γ } go e@(EIte b e1 e2) = go b >>= \b' -> evalIte γ stk e b' e1 e2 go (ECoerc s t e) = ECoerc s t <$> go e - go e@(EApp _ _) = evalArgs γ stk e >>= evalApp γ stk e + go e@(EApp _ _) = evalArgs γ stk e >>= evalApp γ stk e go e@(EVar _) = evalApp γ stk e (e, []) go (PAtom r e1 e2) = PAtom r <$> go e1 <*> go e2 go (ENeg e) = ENeg <$> go e @@ -446,21 +451,18 @@ go (PNot e) = PNot <$> go e go (PImp e1 e2) = PImp <$> go e1 <*> go e2 go (PIff e1 e2) = PIff <$> go e1 <*> go e2 - go (PAnd es) = PAnd <$> (go <$$> es) - go (POr es) = POr <$> (go <$$> es) + go (PAnd es) = PAnd <$> (go `traverse` es) + go (POr es) = POr <$> (go `traverse` es) go e = return e -(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b] -f <$$> xs = f Misc.<$$> xs - -- | `evalArgs` also evaluates all the partial applications for hacky reasons, --- suppose `foo g = id` then we want `foo g 10 = 10` and for that we need +-- suppose `foo g = id` then we want `foo g 10 = 10` and for that we need -- to `eval` the term `foo g` into `id` to tickle the `eval` on `id 10`. --- This seems a bit of a hack. At any rate, this can lead to divergence. +-- This seems a bit of a hack. At any rate, this can lead to divergence. -- TODO: distill a .fq test from the MOSSAKA-hw3 example. evalArgs :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr]) -evalArgs γ stk e = go [] e +evalArgs γ stk e = go [] e where go acc (EApp f e) = do f' <- evalOk γ stk f @@ -472,41 +474,41 @@ -- | Minimal test case illustrating this `evalOk` hack is LH#tests/ple/pos/MossakaBug.hs -- too tired & baffled to generate simple .fq version. TODO:nuke and rewrite PLE! evalOk :: Knowledge -> CStack -> Expr -> EvalST Expr -evalOk γ stk@(_, Ok) e = eval γ stk e -evalOk _ _ e = pure e +evalOk γ stk@(_, Ok) e = eval γ stk e +evalOk _ _ e = pure e -{- +{- evalArgs :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr]) -evalArgs - | True = evalArgsOLD - | False = evalArgsNEW +evalArgs + | True = evalArgsOLD + | False = evalArgsNEW evalArgsNEW :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr]) -evalArgsNEW γ stk e = do - let (e1, es) = splitEApp e - e1' <- eval γ stk e1 - es' <- mapM (eval γ stk) es +evalArgsNEW γ stk e = do + let (e1, es) = splitEApp e + e1' <- eval γ stk e1 + es' <- mapM (eval γ stk) es return (e1', es') -} - + evalApp :: Knowledge -> CStack -> Expr -> (Expr, [Expr]) -> EvalST Expr -- evalApp γ stk e (e1, es) = tracepp ("evalApp:END" ++ showpp (e1,es)) <$> (evalAppAc γ stk e (e1, es)) -evalApp γ stk e (e1, es) = do +evalApp γ stk e (e1, es) = do res <- evalAppAc γ stk e (e1, es) - let diff = (res /= (eApps e1 es)) - return $ mytracepp ("evalApp:END:" ++ showpp diff) res + let diff = res /= eApps e1 es + return $ mytracepp ("evalApp:END:" ++ showpp diff) res evalAppAc :: Knowledge -> CStack -> Expr -> (Expr, [Expr]) -> EvalST Expr -{- MOSSAKA-} +{- MOSSAKA-} evalAppAc γ stk e (EVar f, [ex]) | (EVar dc, es) <- splitEApp ex , Just simp <- L.find (\simp -> (smName simp == f) && (smDC simp == dc)) (knSims γ) , length (smArgs simp) == length es = do let msg = "evalAppAc:ePop: " ++ showpp (f, dc, es) let ePopIf = mytracepp msg $ substPopIf (zip (smArgs simp) es) (smBody simp) - e' <- eval γ stk ePopIf + e' <- eval γ stk ePopIf (e, "Rewrite -" ++ showpp f) ~> e' evalAppAc γ stk _ (EVar f, es) @@ -514,20 +516,20 @@ | Just eq <- L.find (( == f) . eqName) (knAms γ) , Just bd <- getEqBody eq , length (eqArgs eq) == length es - , f `notElem` syms bd -- non-recursive equations << HACK! misses MUTUALLY RECURSIVE definitions! - , recurCS stk f - = do env <- seSort <$> gets evEnv + , f `notElem` syms bd -- non-recursive equations << HACK! misses MUTUALLY RECURSIVE definitions! + , recurCS stk f + = do env <- gets (seSort . evEnv) let ee = substEq env PopIf eq es bd - assertSelectors γ ee - eval γ (pushCS stk f) ee + assertSelectors γ ee + eval γ (pushCS stk f) ee evalAppAc γ stk _e (EVar f, es) | Just eq <- L.find ((== f) . eqName) (knAms γ) , Just bd <- getEqBody eq , length (eqArgs eq) == length es -- recursive equations - , recurCS stk f - = do env <- seSort <$> gets evEnv - mytracepp ("EVAL-REC-APP" ++ showpp (stk, _e)) + , recurCS stk f + = do env <- gets (seSort . evEnv) + mytracepp ("EVAL-REC-APP" ++ showpp (stk, _e)) <$> evalRecApplication γ (pushCS stk f) (eApps (EVar f) es) (substEq env Normal eq es bd) evalAppAc _ _ _ (f, es) @@ -553,20 +555,20 @@ substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr -> Expr substEqCoerce env eq es bd = Vis.applyCoSub coSub bd - where + where ts = snd <$> eqArgs eq sp = panicSpan "mkCoSub" eTs = sortExpr sp env <$> es coSub = mytracepp ("substEqCoerce" ++ showpp (eqName eq, es, eTs, ts)) $ mkCoSub env eTs ts mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub -mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] +mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] where unite ts = mytracepp ("UNITE: " ++ showpp ts) $ Mb.fromMaybe (uError ts) (unifyTo1 senv ts) senv = mkSearchEnv env - uError ts = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) + uError ts = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) xys = mytracepp "mkCoSubXXX" $ Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs - (_xTs,_eTs) = mytracepp "mkCoSub:MATCH" $ (xTs, eTs) + (_xTs,_eTs) = mytracepp "mkCoSub:MATCH" (xTs, eTs) matchSorts :: Sort -> Sort -> [(Symbol, Sort)] matchSorts s1 s2 = mytracepp ("matchSorts :" ++ showpp (s1, s2)) $ go s1 s2 @@ -616,16 +618,16 @@ b1 <- liftIO (isValid γ b') if b1 then addEquality γ e e1 >> - ({- SCC "assertSelectors-1" #-} assertSelectors γ e1) >> + {- SCC "assertSelectors-1" -} assertSelectors γ e1 >> eval γ stk (mytracepp ("evalREC-1: " ++ showpp stk) e1) >>= ((e, "App1: ") ~>) else do b2 <- liftIO (isValid γ (PNot b')) if b2 then addEquality γ e e2 >> - ({- SCC "assertSelectors-2" #-} assertSelectors γ e2) >> + {- SCC "assertSelectors-2" -} assertSelectors γ e2 >> eval γ stk (mytracepp ("evalREC-2: " ++ showpp stk) e2) >>= - ((e, ("App2: " ++ showpp stk ) ) ~>) + ((e, "App2: " ++ showpp stk ) ~>) else return e evalRecApplication _ _ _ e = return e @@ -635,14 +637,14 @@ modify (\st -> st{evSequence = (makeLam γ e1, makeLam γ e2):evSequence st}) evalIte :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> EvalST Expr -evalIte γ stk e b e1 e2 = mytracepp "evalIte:END: " <$> - evalIteAc γ stk e b e1 (mytracepp msg e2) - where - msg = "evalIte:BEGINS: " ++ showpp (stk, e) +evalIte γ stk e b e1 e2 = mytracepp "evalIte:END: " <$> + evalIteAc γ stk e b e1 (mytracepp msg e2) + where + msg = "evalIte:BEGINS: " ++ showpp (stk, e) evalIteAc :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> EvalST Expr -evalIteAc γ stk e b e1 e2 +evalIteAc γ stk e b e1 e2 = join $ evalIte' γ stk e b e1 e2 <$> liftIO (isValid γ b) <*> liftIO (isValid γ (PNot b)) evalIte' :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> Bool -> Bool -> EvalST Expr @@ -655,14 +657,14 @@ = do e' <- eval γ stk e2 (e, "If-False") ~> e' evalIte' γ stk _ b e1 e2 _ _ - -- see [NOTE:Eval-Ite] #387 - = EIte b <$> eval γ stk' e1 <*> eval γ stk' e2 - where stk' = mytracepp "evalIte'" $ noRecurCS stk + -- see [NOTE:Eval-Ite] #387 + = EIte b <$> eval γ stk' e1 <*> eval γ stk' e2 + where stk' = mytracepp "evalIte'" $ noRecurCS stk -------------------------------------------------------------------------------- -- | Knowledge (SMT Interaction) -------------------------------------------------------------------------------- -data Knowledge = KN +data Knowledge = KN { knSims :: ![Rewrite] -- ^ Measure info, asserted for each new Ctor ('assertSelectors') , knAms :: ![Equation] -- ^ (Recursive) function definitions, used for PLE , knContext :: SMT.Context @@ -671,20 +673,20 @@ } isValid :: Knowledge -> Expr -> IO Bool -isValid γ e = mytracepp ("isValid: " ++ showpp e) <$> +isValid γ e = mytracepp ("isValid: " ++ showpp e) <$> knPreds γ (knContext γ) (knLams γ) e -isProof :: (a, SortedReft) -> Bool +isProof :: (a, SortedReft) -> Bool isProof (_, RR s _) = showpp s == "Tuple" knowledge :: Config -> SMT.Context -> AxiomEnv -> Knowledge -knowledge cfg ctx aenv = KN +knowledge cfg ctx aenv = KN { knSims = aenvSimpl aenv , knAms = aenvEqs aenv - , knContext = ctx - , knPreds = askSMT cfg - , knLams = [] - } + , knContext = ctx + , knPreds = askSMT cfg + , knLams = [] + } -- | This creates the rewrite rule e1 -> e2, applied when: -- 1. when e2 is a DataCon and can lead to further reductions @@ -693,26 +695,15 @@ initEqualities ctx aenv es = concatMap (makeSimplifications (aenvSimpl aenv)) dcEqs where dcEqs = Misc.hashNub (Mb.catMaybes [getDCEquality senv e1 e2 | EEq e1 e2 <- atoms]) - atoms = splitPAnd =<< (expr <$> filter isProof es) + atoms = splitPAnd . expr =<< filter isProof es senv = SMT.ctxSymEnv ctx --- AT: Non-obvious needed invariant: askSMT True is always the +-- AT: Non-obvious needed invariant: askSMT True is always the -- totality-effecting one. --- RJ: What does "totality effecting" mean? - -askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool -askSMT cfg ctx bs e - | isTautoPred e = return True - | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e' - | otherwise = return False - where - e' = toSMT cfg ctx bs e +-- RJ: What does "totality effecting" mean? toSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred -toSMT cfg ctx bs = defuncAny cfg senv . elaborate "makeKnowledge" (elabEnv bs) - where - elabEnv = insertsSymEnv senv - senv = SMT.ctxSymEnv ctx +toSMT = Common.toSMT "Instantiate.toSMT" makeSimplifications :: [Rewrite] -> (Symbol, [Expr], Expr) -> [(Expr, Expr)] makeSimplifications sis (dc, es, e) @@ -750,9 +741,9 @@ = Nothing isUpperSymbol :: Symbol -> Bool -isUpperSymbol x = (0 < lengthSym x') && (isUpper $ headSym x') - where - x' = dropModuleNames x +isUpperSymbol x = (0 < lengthSym x') && isUpper (headSym x') + where + x' = dropModuleNames x dropModuleNames :: Symbol -> Symbol dropModuleNames = mungeNames (symbol . last) "." @@ -782,11 +773,10 @@ assertSelectors :: Knowledge -> Expr -> EvalST () assertSelectors γ e = do - sims <- aenvSimpl <$> gets _evAEnv + sims <- gets (aenvSimpl . _evAEnv) -- cfg <- gets evCfg -- _ <- foldlM (\_ s -> Vis.mapMExpr (go s) e) (mytracepp "assertSelector" e) sims forM_ sims $ \s -> Vis.mapMExpr (go s) e - return () where go :: Rewrite -> Expr -> EvalST Expr go (SMeasure f dc xs bd) e@(EApp _ _) @@ -812,9 +802,9 @@ _ <- SMT.cleanupContext ctx return res +infixl 9 ~> (~>) :: (Expr, String) -> Expr -> EvalST Expr (e, _str) ~> e' = do - let msg = "PLE: " ++ _str ++ showpp (e, e') - modify (\st -> st {evId = (mytracepp msg $ evId st) + 1}) + let msg = "PLE: " ++ _str ++ showpp (e, e') + modify (\st -> st {evId = mytracepp msg (evId st) + 1}) return e' - diff --git a/src/Language/Fixpoint/Solver/Interpreter.hs b/src/Language/Fixpoint/Solver/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Interpreter.hs @@ -0,0 +1,733 @@ +-------------------------------------------------------------------------------- +-- | This module is a preliminary part of the implementation of "Proof by +-- Logical Evaluation" where we unfold function definitions if they *must* be +-- unfolded, to strengthen the environments with function-definition-equalities. +-- +-- In this module, we attempt to verify as many of the PLE constaints as +-- possible without invoking the SMT solver or performing any I/O at all. +-- To this end, we use an interpreter in Haskell to attempt to evaluate down +-- expressions and generate equalities. +-------------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Language.Fixpoint.Solver.Interpreter + ( instInterpreter + + -- The following exports are for property testing. + , ICtx(..) + , Knowledge(..) + , Simplifiable(..) + , interpret + ) where + +import Language.Fixpoint.Types hiding (simplify) +import Language.Fixpoint.Types.Config as FC +import Language.Fixpoint.Types.Solutions (CMap) +import qualified Language.Fixpoint.Types.Visitor as Vis +import qualified Language.Fixpoint.Misc as Misc +import Language.Fixpoint.Defunctionalize +import qualified Language.Fixpoint.Utils.Trie as T +import Language.Fixpoint.Utils.Progress +import Language.Fixpoint.SortCheck +import Language.Fixpoint.Graph.Deps (isTarget) +import Language.Fixpoint.Solver.Sanitize (symbolEnv) +import Language.Fixpoint.Solver.Simplify +import Control.Monad.State +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.List as L +import qualified Data.Maybe as Mb +--import Debug.Trace (trace) + +mytracepp :: (PPrint a) => String -> a -> a +mytracepp = notracepp + +--mytrace :: String -> a -> a +--mytrace = {-trace-} flip const + +-------------------------------------------------------------------------------- +-- | Strengthen Constraint Environments via PLE +-------------------------------------------------------------------------------- +instInterpreter :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) +instInterpreter cfg fi' subcIds = do + let cs = M.filterWithKey + (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds) + (cm fi) + let t = mkCTrie (M.toList cs) -- 1. BUILD the Trie + res <- withProgress (1 + M.size cs) $ + pleTrie t $ instEnv fi cs sEnv -- 2. TRAVERSE Trie to compute InstRes + return $ resSInfo cfg sEnv fi res -- 3. STRENGTHEN SInfo using InstRes + where + sEnv = symbolEnv cfg fi + aEnv = ae fi + fi = normalize fi' + +------------------------------------------------------------------------------- +-- | Step 1a: @instEnv@ sets up the incremental-PLE environment +instEnv :: (Loc a) => SInfo a -> CMap (SimpC a) -> SymEnv -> InstEnv a +instEnv fi cs sEnv = InstEnv bEnv aEnv cs γ s0 + where + csBinds = M.foldl' (\acc c -> unionIBindEnv acc (senv c)) emptyIBindEnv cs + bEnv = filterBindEnv (\i _ _ -> memberIBindEnv i csBinds) (bs fi) + aEnv = ae fi + γ = knowledge fi + s0 = EvalEnv sEnv mempty + +---------------------------------------------------------------------------------------------- +-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments +mkCTrie :: [(SubcId, SimpC a)] -> CTrie +mkCTrie ics = T.fromList [ (cBinds c, i) | (i, c) <- ics ] + where + cBinds = L.sort . elemsIBindEnv . senv + +---------------------------------------------------------------------------------------------- +-- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE +pleTrie :: CTrie -> InstEnv a -> IO InstRes +pleTrie t env = loopT env ctx0 diff0 Nothing res0 t + where + diff0 = [] + res0 = M.empty + ctx0 = initCtx env ((mkEq <$> es0) ++ (mkEq' <$> es0')) + es0 = L.filter (null . eqArgs) (aenvEqs . ieAenv $ env) + es0' = L.filter (null . smArgs) (aenvSimpl . ieAenv $ env) + mkEq eq = (EVar $ eqName eq, eqBody eq) + mkEq' rw = (EApp (EVar $ smName rw) (EVar $ smDC rw), smBody rw) + +loopT :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CTrie -> IO InstRes +loopT env ctx delta i res t = case t of + T.Node [] -> return res + T.Node [b] -> loopB env ctx delta i res b + T.Node bs -> withAssms env ctx delta Nothing $ \ctx' -> do + (ctx'', res') <- ple1 env ctx' i res + foldM (loopB env ctx'' [] i) res' bs + +loopB :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CBranch -> IO InstRes +loopB env ctx delta iMb res b = case b of + T.Bind i t -> loopT env ctx (i:delta) (Just i) res t + T.Val cid -> withAssms env ctx delta (Just cid) $ \ctx' -> do + progressTick + snd <$> ple1 env ctx' iMb res + +-- Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@ +-- and the rhs of @cidMb@. +-- +-- Adds to @ctx@ assumptions from @env@ and @delta@ plus rewrites that +-- candidates can use +withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b +withAssms env@InstEnv{} ctx delta cidMb act = act $ + updCtx env ctx delta cidMb + +-- | @ple1@ performs the PLE at a single "node" in the Trie +ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstRes) +ple1 InstEnv{..} ctx i res = + updCtxRes res i <$> evalCandsLoop {-anfEnv-} M.empty ctx ieKnowl ieEvEnv + +evalCandsLoop :: ConstMap -> ICtx -> Knowledge -> EvalEnv -> IO ICtx +evalCandsLoop ie ictx0 γ env = go ictx0 + where + withRewrites exprs = + let + rws = [rewrite e rw | rw <- snd <$> M.toList (knSims γ) + , e <- S.toList (snd `S.map` exprs)] + in + exprs <> S.fromList (concat rws) + go ictx | S.null (icCands ictx) = return ictx + go ictx = do let cands = icCands ictx + let env' = env { evAccum = icEquals ictx <> evAccum env } + (ictx', evalResults) <- + foldM (evalOneCandStep ie γ env') (ictx, []) (S.toList cands) + let us = mconcat evalResults + if S.null (us `S.difference` icEquals ictx) + then return ictx + else do let oks = fst `S.map` us + let us' = withRewrites us + let ictx'' = ictx' { icSolved = icSolved ictx <> oks + , icEquals = icEquals ictx <> us' } + let newcands = mconcat (makeCandidates γ ictx'' <$> S.toList (cands <> (snd `S.map` us))) + go (ictx'' { icCands = S.fromList newcands}) + +-- evalOneCands :: Knowledge -> EvalEnv -> ICtx -> [Expr] -> IO (ICtx, [EvAccum]) +-- evalOneCands γ env' ictx = foldM step (ictx, []) +evalOneCandStep :: ConstMap -> Knowledge -> EvalEnv -> (ICtx, [EvAccum]) -> Expr -> IO (ICtx, [EvAccum]) +evalOneCandStep env γ env' (ictx, acc) e = do + res <- evalOne env γ env' ictx e + return (ictx, res : acc) + +rewrite :: Expr -> Rewrite -> [(Expr,Expr)] +rewrite e rw = Mb.mapMaybe (`rewriteTop` rw) (notGuardedApps e) + +rewriteTop :: Expr -> Rewrite -> Maybe (Expr,Expr) +rewriteTop e rw + | (EVar f, es) <- splitEApp e + , f == smDC rw + , length es == length (smArgs rw) + = Just (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw)) + | otherwise + = Nothing + +---------------------------------------------------------------------------------------------- +-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo +---------------------------------------------------------------------------------------------- + +resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a +resSInfo cfg env fi res = strengthenBinds fi res' + where + res' = M.fromList $ zip is ps'' + ps'' = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' + ps' = defuncAny cfg env ps + (is, ps) = unzip (M.toList res) + +---------------------------------------------------------------------------------------------- +-- | @InstEnv@ has the global information needed to do PLE +---------------------------------------------------------------------------------------------- + +data InstEnv a = InstEnv + { ieBEnv :: !(BindEnv a) + , ieAenv :: !AxiomEnv + , ieCstrs :: !(CMap (SimpC a)) + , ieKnowl :: !Knowledge + , ieEvEnv :: !EvalEnv + } + +---------------------------------------------------------------------------------------------- +-- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE +---------------------------------------------------------------------------------------------- + +data ICtx = ICtx + { icCands :: S.HashSet Expr -- ^ "Candidates" for unfolding + , icEquals :: EvAccum -- ^ Accumulated equalities + , icSolved :: S.HashSet Expr -- ^ Terms that we have already expanded + , icSimpl :: !ConstMap -- ^ Map of expressions to constants + , icSubcId :: Maybe SubcId -- ^ Current subconstraint ID + } + +---------------------------------------------------------------------------------------------- +-- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId +---------------------------------------------------------------------------------------------- + +type InstRes = M.HashMap BindId Expr + +---------------------------------------------------------------------------------------------- +-- | @Unfold is the result of running PLE at a single equality; +-- (e, [(e1, e1')...]) is the source @e@ and the (possible empty) +-- list of PLE-generated equalities (e1, e1') ... +---------------------------------------------------------------------------------------------- + +type CTrie = T.Trie SubcId +type CBranch = T.Branch SubcId +type Diff = [BindId] -- ^ in "reverse" order + +initCtx :: InstEnv a -> [(Expr,Expr)] -> ICtx +initCtx _ es = ICtx + { icCands = mempty + , icEquals = S.fromList es + , icSolved = mempty + , icSimpl = mempty + , icSubcId = Nothing + } + +equalitiesPred :: S.HashSet (Expr, Expr) -> [Expr] +equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- S.toList eqs, e1 /= e2 ] + +updCtxRes :: InstRes -> Maybe BindId -> ICtx -> (ICtx, InstRes) +updCtxRes res iMb ctx = (ctx, res') + where + res' = updRes res iMb (pAnd $ equalitiesPred $ icEquals ctx) + + +updRes :: InstRes -> Maybe BindId -> Expr -> InstRes +updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res +updRes res Nothing _ = res + + +---------------------------------------------------------------------------------------------- +-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ +-- to the context. +---------------------------------------------------------------------------------------------- + +updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx +updCtx InstEnv{..} ctx delta cidMb + = ctx { icCands = S.fromList cands <> icCands ctx + , icEquals = initEqs <> icEquals ctx + , icSimpl = M.fromList (S.toList sims) <> icSimpl ctx <> econsts + , icSubcId = cidMb -- fst <$> L.find (\(_, b) -> (head delta) `memberIBindEnv` (_cenv b)) ieCstrs + } -- eliminate above if nothing broken + where + initEqs = S.fromList $ concat [rewrite e rw | e <- cands ++ (snd <$> S.toList (icEquals ctx)) + , rw <- snd <$> M.toList (knSims ieKnowl)] + cands = concatMap (makeCandidates ieKnowl ctx) (rhs:es) + sims = S.filter (isSimplification (knDCs ieKnowl)) (initEqs <> icEquals ctx) + econsts = M.fromList $ findConstants ieKnowl es + rhs = unElab eRhs + es = unElab . expr <$> [ (x, y) | (x, y,_ ) <- binds ] + eRhs = maybe PTrue crhs subMb + binds = [ lookupBindEnv i ieBEnv | i <- delta ] + subMb = getCstr ieCstrs <$> cidMb + + +findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)] +findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)] + where + go su ess = if ess == ess' + then su + else go (su ++ su') ess' + where ess' = subst (mkSubst su') <$> ess + su' = makeSu ess + makeSu exprs = [(x,c) | (EEq (EVar x) c) <- exprs + , isConstant (knDCs γ) c + , EVar x /= c ] + +makeCandidates :: Knowledge -> ICtx -> Expr -> [Expr] +makeCandidates γ ctx expr + = mytracepp ("\n" ++ show (length cands) ++ " New Candidates") cands + where + cands = + filter (\e -> isRedex γ e && not (e `S.member` icSolved ctx)) (notGuardedApps expr) ++ + filter (\e -> hasConstructors γ e && not (e `S.member` icSolved ctx)) (largestApps expr) + + -- Constructor occurrences need to be considered as candidadates since + -- they identify relevant measure equations. The function 'rewrite' + -- introduces these equations. + hasConstructors :: Knowledge -> Expr -> Bool + hasConstructors γ e = not $ S.null $ S.intersection (exprSymbolsSet e) (knDCs γ) + +isRedex :: Knowledge -> Expr -> Bool +isRedex γ e = isGoodApp γ e || isIte e + where + isIte EIte {} = True + isIte _ = False + + +isGoodApp :: Knowledge -> Expr -> Bool +isGoodApp γ e + | (EVar f, es) <- splitEApp e + , Just i <- L.lookup f (knSummary γ) + = length es >= i + | otherwise + = False + + + + +getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a +getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env + +isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool +isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) + +type EvAccum = S.HashSet (Expr, Expr) + +-------------------------------------------------------------------------------- +data EvalEnv = EvalEnv + { evEnv :: !SymEnv + , evAccum :: EvAccum + } + +type EvalST a = StateT EvalEnv IO a +-------------------------------------------------------------------------------- + + +evalOne :: ConstMap -> Knowledge -> EvalEnv -> ICtx -> Expr -> IO EvAccum +evalOne ienv γ env ctx e {- null (getAutoRws γ ctx) -} = do + (e', st) <- runStateT (fastEval ienv γ ctx e) env + let evAcc' = if mytracepp ("evalOne: " ++ showpp e) e' == e then evAccum st else S.insert (e, e') (evAccum st) + return evAcc' + +notGuardedApps :: Expr -> [Expr] +notGuardedApps = flip go [] + where + go e0 acc = case e0 of + EApp e1 e2 -> e0 : go e1 (go e2 acc) + PAnd es -> foldr go acc es + POr es -> foldr go acc es + PAtom _ e1 e2 -> go e1 $ go e2 acc + PIff e1 e2 -> go e1 $ go e2 acc + PImp e1 e2 -> go e1 $ go e2 acc + EBin _ e1 e2 -> go e1 $ go e2 acc + PNot e -> go e acc + ENeg e -> go e acc + EIte b _ _ -> go b $ e0 : acc + ECoerc _ _ e -> go e acc + ECst e _ -> go e acc + ESym _ -> acc + ECon _ -> acc + EVar _ -> acc + ELam _ _ -> acc + ETApp _ _ -> acc + ETAbs _ _ -> acc + PKVar _ _ -> acc + PAll _ _ -> acc + PExist _ _ -> acc + PGrad{} -> acc + +largestApps :: Expr -> [Expr] +largestApps = flip go [] + where + go e0 acc = case e0 of + EApp _ _ -> e0 : acc + PAnd es -> foldr go acc es + POr es -> foldr go acc es + PAtom _ e1 e2 -> go e1 $ go e2 acc + PIff e1 e2 -> go e1 $ go e2 acc + PImp e1 e2 -> go e1 $ go e2 acc + EBin _ e1 e2 -> go e1 $ go e2 acc + PNot e -> go e acc + ENeg e -> go e acc + EIte b _ _ -> go b $ e0 : acc + ECoerc _ _ e -> go e acc + ECst e _ -> go e acc + ESym _ -> acc + ECon _ -> acc + EVar _ -> e0 : acc + ELam _ _ -> acc + ETApp _ _ -> acc + ETAbs _ _ -> acc + PKVar _ _ -> acc + PAll _ _ -> acc + PExist _ _ -> acc + PGrad{} -> acc + +fastEval :: ConstMap -> Knowledge -> ICtx -> Expr -> EvalST Expr +fastEval ienv γ ctx e + = do env <- gets (seSort . evEnv) + return $ mytracepp ("evaluating" ++ show e) $ interpret ienv γ ctx env $ simplify γ ctx e + +-------------------------------------------------------------------------------- +-- | 'substEq' unfolds or instantiates an equation at a particular list of +-- argument values. We must also substitute the sort-variables that appear +-- as coercions. See tests/proof/ple1.fq +-------------------------------------------------------------------------------- + +unfoldExpr :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> {-EvalST-} Expr +unfoldExpr ie γ ctx env (EIte e0 e1 e2) = let g' = interpret' ie γ ctx env e0 in + if g' == PTrue + then unfoldExpr ie γ ctx env e1 + else if g' == PFalse + then unfoldExpr ie γ ctx env e2 + else EIte g' e1 e2 +unfoldExpr _ _ _ _ e = e + +substEq :: SEnv Sort -> Equation -> [Expr] -> Expr +substEq env eq es = subst su (substEqCoerce env eq es) + where su = mkSubst $ zip (eqArgNames eq) es + +substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr +substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq + where + ts = snd <$> eqArgs eq + sp = panicSpan "mkCoSub" + eTs = sortExpr sp env <$> es + coSub = mkCoSub env eTs ts + +mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub +mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] + where + unite ts = Mb.fromMaybe (uError ts) (unifyTo1 senv ts) + senv = mkSearchEnv env + uError ts = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) + xys = Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs + (_xTs,_eTs) = (xTs, eTs) + +matchSorts :: Sort -> Sort -> [(Symbol, Sort)] +matchSorts s1 s2 = go s1 s2 + where + go (FObj x) {-FObj-} y = [(x, y)] + go (FAbs _ t1) (FAbs _ t2) = go t1 t2 + go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2 + go (FApp s1 t1) (FApp s2 t2) = go s1 s2 ++ go t1 t2 + go _ _ = [] + +-------------------------------------------------------------------------------- + +eqArgNames :: Equation -> [Symbol] +eqArgNames = map fst . eqArgs + +interpret' :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr +interpret' ie γ ctx env e = mytracepp ("Interpreting " ++ show e) $ interpret ie γ ctx env e + +interpret :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr +interpret _ _ _ _ e@(ESym _) = e +interpret _ _ _ _ e@(ECon _) = e +interpret ie γ ctx env (EVar sym) + | Just e' <- M.lookup (EVar sym) (icSimpl ctx) + = interpret' ie γ ctx env e' +interpret _ _ _ _ e@(EVar _) = e +interpret ie γ ctx env (EApp e1 e2) + | isSetPred e1 = let e2' = interpret' ie γ ctx env e2 in + applySetFolding e1 e2' +interpret ie γ ctx env e@(EApp _ _) = case splitEApp e of + (f, es) -> let g = interpret' ie γ ctx env in + interpretApp ie γ ctx env (g f) (map g es) + where + interpretApp ie γ ctx env (EVar f) es + | Just eq <- M.lookup f (knAms γ) + , length (eqArgs eq) <= length es + = let (es1,es2) = splitAt (length (eqArgs eq)) es + ges = substEq env eq es1 + exp = unfoldExpr ie γ ctx env ges + exp' = eApps exp es2 in --exp' -- TODO undo + if eApps (EVar f) es == exp' then exp' else interpret' ie γ ctx env exp' + + interpretApp ie γ ctx env (EVar f) (e1:es) + | (EVar dc, as) <- splitEApp e1 + , Just rw <- M.lookup (f, dc) (knSims γ) + , length as == length (smArgs rw) + = let e' = eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es in --e' -- TODO undo + if eApps (EVar f) es == e' then e' else interpret' ie γ ctx env e' + + interpretApp _ γ _ _ (EVar f) [e0] + | (EVar dc, _as) <- splitEApp e0 + , isTestSymbol f + = if testSymbol dc == f then PTrue else + if S.member dc (knAllDCs γ) then PFalse else {-simplify γ ctx $-} eApps (EVar f) [e0] + + interpretApp _ _ _ _ f es = {-simplify γ ctx $-} eApps f es +interpret ie γ ctx env (ENeg e1) = let e1' = interpret' ie γ ctx env e1 in + applyConstantFolding Minus (ECon (I 0)) e1' +-- simplify γ ctx (ENeg e1') +interpret ie γ ctx env (EBin o e1 e2) = let e1' = interpret' ie γ ctx env e1 + e2' = interpret' ie γ ctx env e2 in + applyConstantFolding o e1' e2' +-- simplify γ ctx (EBin o e1' e2') +interpret ie γ ctx env (EIte g e1 e2) = let b = interpret' ie γ ctx env g in + if b == PTrue then interpret' ie γ ctx env e1 else + if b == PFalse then interpret' ie γ ctx env e2 else + simplify γ ctx $ EIte b e1 e2 +-- EIte b (interpret' γ ctx env e1) (interpret' γ ctx env e2) +interpret ie γ ctx env (ECst e1 s) = let e1' = interpret' ie γ ctx env e1 in + simplifyCasts e1' s -- ECst e1' s +interpret ie γ ctx env (ELam (x,s) e) = let γ' = γ { knLams = (x, s) : knLams γ } + e' = interpret' ie γ' ctx env e in + ELam (x, s) e' +interpret ie γ ctx env (ETApp e1 t) = let e1' = interpret' ie γ ctx env e1 in ETApp e1' t +interpret ie γ ctx env (ETAbs e1 sy) = let e1' = interpret' ie γ ctx env e1 in ETAbs e1' sy +interpret ie γ ctx env (PAnd es) = let es' = map (interpret' ie γ ctx env) es in go [] (reverse es') + where + go [] [] = PTrue + go [p] [] = interpret' ie γ ctx env p + go acc [] = PAnd acc + go acc (PTrue:es) = go acc es + go _ (PFalse:_) = PFalse + go acc (e:es) = go (e:acc) es +interpret ie γ ctx env (POr es) = let es' = map (interpret' ie γ ctx env) es in go [] (reverse es') + where + go [] [] = PFalse + go [p] [] = interpret' ie γ ctx env p + go acc [] = POr acc + go _ (PTrue:_) = PTrue + go acc (PFalse:es) = go acc es + go acc (e:es) = go (e:acc) es +interpret ie γ ctx env (PNot e) = let e' = interpret' ie γ ctx env e in case e' of + (PNot e'') -> e'' + PTrue -> PFalse + PFalse -> PTrue + _ -> PNot e' +interpret ie γ ctx env (PImp e1 e2) = let e1' = interpret' ie γ ctx env e1 + e2' = interpret' ie γ ctx env e2 in + if e1' == PFalse || e2' == PTrue then PTrue else + if e1' == PTrue then e2' else + if e2' == PFalse then interpret' ie γ ctx env (PNot e1') else + PImp e1' e2' +interpret ie γ ctx env (PIff e1 e2) = let e1' = interpret' ie γ ctx env e1 + e2' = interpret' ie γ ctx env e2 in + if e1' == PTrue then e2' else + if e2' == PTrue then e1' else + if e1' == PFalse then interpret' ie γ ctx env (PNot e2') else + if e2' == PFalse then interpret' ie γ ctx env (PNot e1') else + PIff e1' e2' +interpret ie γ ctx env (PAtom o e1 e2) = let e1' = interpret' ie γ ctx env e1 + e2' = interpret' ie γ ctx env e2 in + applyBooleanFolding o e1' e2' +interpret _ _ _ _ e@(PKVar _ _) = e +interpret ie γ ctx env e@(PAll xss e1) = case xss of + [] -> interpret' ie γ ctx env e1 + _ -> e +interpret ie γ ctx env e@(PExist xss e1) = case xss of + [] -> interpret' ie γ ctx env e1 + _ -> e +interpret _ _ _ _ e@PGrad{} = e +interpret ie γ ctx env (ECoerc s t e) = let e' = interpret' ie γ ctx env e in + if s == t then e' else ECoerc s t e' + + +-------------------------------------------------------------------------------- +-- | Knowledge (SMT Interaction) +-------------------------------------------------------------------------------- +data Knowledge = KN + { knSims :: M.HashMap (Symbol, Symbol) Rewrite -- ^ Rewrite rules came from match and data type definitions + , knAms :: M.HashMap Symbol Equation -- ^ All function definitions -- restore ! here? + , knLams :: ![(Symbol, Sort)] + , knSummary :: ![(Symbol, Int)] -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity + , knDCs :: !(S.HashSet Symbol) -- ^ data constructors drawn from Rewrite + , knAllDCs :: !(S.HashSet Symbol) -- ^ + , knSels :: !SelectorMap + , knConsts :: !ConstDCMap + } + +knowledge :: SInfo a -> Knowledge +knowledge si = KN + { knSims = M.fromList $ (\r -> ((smName r, smDC r), r)) <$> sims + , knAms = M.fromList $ (\a -> (eqName a, a)) <$> aenvEqs aenv + , knLams = [] + , knSummary = ((\s -> (smName s, 1)) <$> sims) + ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv) + , knDCs = S.fromList (smDC <$> sims) <> constNames si + , knAllDCs = S.fromList $ val . dcName <$> concatMap ddCtors (ddecls si) + , knSels = M.fromList $ Mb.mapMaybe makeSel sims + , knConsts = M.fromList $ Mb.mapMaybe makeCons sims + } + where + sims = aenvSimpl aenv + aenv = ae si + + makeCons rw + | null (syms $ smBody rw) + = Just (smName rw, (smDC rw, smBody rw)) + | otherwise + = Nothing + + makeSel rw + | EVar x <- smBody rw + = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw) + | otherwise + = Nothing + + constNames si = (S.fromList . map fst . toListSEnv . gLits $ si) `S.union` + (S.fromList . map fst . toListSEnv . dLits $ si) +-- testSymbol (from names) + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi, +-- i.e., sel_i selects the ith value for the data constructor D +type SelectorMap = M.HashMap Symbol (Symbol, Int) +type ConstDCMap = M.HashMap Symbol (Symbol, Expr) + +-- ValueMap maps expressions to constants (including data constructors) +type ConstMap = M.HashMap Expr Expr +type LDataCon = Symbol -- Data Constructors + +isSimplification :: S.HashSet LDataCon -> (Expr,Expr) -> Bool +isSimplification dcs (_,c) = isConstant dcs c + +isConstant :: S.HashSet LDataCon -> Expr -> Bool +isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs) + +class Simplifiable a where + simplify :: Knowledge -> ICtx -> a -> a + + +instance Simplifiable Expr where + simplify γ ictx e = mytracepp ("simplification of " ++ show e) $ fix (Vis.mapExpr tx) e + where + fix f e = if e == e' then e else fix f e' where e' = f e + tx e + | Just e' <- M.lookup e (icSimpl ictx) + = e' + + tx (PAtom rel e1 e2) = applyBooleanFolding rel e1 e2 + tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2 + tx (ENeg e) = applyConstantFolding Minus (ECon (I 0)) e + tx (EApp e1 e2) + | isSetPred e1 = applySetFolding e1 e2 + + tx (EApp (EVar f) a) + | Just (dc, c) <- M.lookup f (knConsts γ) + , (EVar dc', _) <- splitEApp a + , dc == dc' + = c + tx (EIte b e1 e2) + | isTautoPred b = e1 + | isContraPred b = e2 + tx (ECst e s) = simplifyCasts e s + tx (ECoerc s t e) + | s == t = e + tx (EApp (EVar f) a) + | Just (dc, i) <- M.lookup f (knSels γ) + , (EVar dc', es) <- splitEApp a + , dc == dc' + = es!!i + tx (PAnd es) = go [] (reverse es) + where + go [] [] = PTrue + go [p] [] = p + go acc [] = PAnd acc + go acc (e:es) + | e == PTrue = go acc es + | e == PFalse = PFalse + | otherwise = go (e:acc) es + tx (POr es) = go [] (reverse es) + where + go [] [] = PFalse + go [p] [] = p + go acc [] = POr acc + go acc (e:es) + | e == PTrue = PTrue + | e == PFalse = go acc es + | otherwise = go (e:acc) es + tx (PNot e) + | e == PTrue = PFalse + | e == PFalse = PTrue + | otherwise = PNot e + tx e = e + +simplifyCasts :: Expr -> Sort -> Expr +simplifyCasts (ECon (I n)) FInt = ECon (I n) +simplifyCasts (ECon (R x)) FReal = ECon (R x) +simplifyCasts e s = ECst e s + +------------------------------------------------------------------------------- +-- | Normalization of Equation: make their arguments unique ------------------- +------------------------------------------------------------------------------- + +class Normalizable a where + normalize :: a -> a + +instance Normalizable (GInfo c a) where + normalize si = si {ae = normalize $ ae si} + +instance Normalizable AxiomEnv where + normalize aenv = aenv { aenvEqs = {-notracepp-} mytracepp "aenvEqs" (normalize <$> aenvEqs aenv) + , aenvSimpl = {-notracepp-} mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) } + +instance Normalizable Rewrite where + normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw } + where + su = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs' + xs = smArgs rw + xs' = zipWith mkSymbol xs [0 :: Integer ..] + mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i + +instance Normalizable Equation where + normalize eq = eq {eqArgs = zip xs' ss, + eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq } + where + su = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs' + (xs,ss) = unzip (eqArgs eq) + xs' = zipWith mkSymbol xs [0 :: Integer ..] + mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i + +normalizeBody :: Symbol -> Expr -> Expr +normalizeBody f = go + where + go e + | elem f (syms e) + = go' e + go e + = e + + go' (PAnd [PImp c e1,PImp (PNot c') e2]) + | c == c' = EIte c e1 (go' e2) + go' e = e diff --git a/src/Language/Fixpoint/Solver/Monad.hs b/src/Language/Fixpoint/Solver/Monad.hs --- a/src/Language/Fixpoint/Solver/Monad.hs +++ b/src/Language/Fixpoint/Solver/Monad.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -- | This is a wrapper around IO that permits SMT queries @@ -59,12 +58,12 @@ -- | Solver Monadic API -------------------------------------------------------- -------------------------------------------------------------------------------- -type SolveM = StateT SolverState IO +type SolveM ann = StateT (SolverState ann) IO -data SolverState = SS - { ssCtx :: !Context -- ^ SMT Solver Context - , ssBinds :: !F.BindEnv -- ^ All variables and types - , ssStats :: !Stats -- ^ Solver Statistics +data SolverState ann = SS + { ssCtx :: !Context -- ^ SMT Solver Context + , ssBinds :: !(F.BindEnv ann) -- ^ All variables and types + , ssStats :: !Stats -- ^ Solver Statistics } stats0 :: F.GInfo c b -> Stats @@ -73,7 +72,7 @@ nCs = M.size $ F.cm fi -------------------------------------------------------------------------------- -runSolverM :: Config -> SolverInfo b c -> SolveM a -> IO a +runSolverM :: Config -> SolverInfo ann c -> SolveM ann a -> IO a -------------------------------------------------------------------------------- runSolverM cfg sI act = bracket acquire release $ \ctx -> do @@ -94,34 +93,34 @@ -------------------------------------------------------------------------------- -getBinds :: SolveM F.BindEnv +getBinds :: SolveM ann (F.BindEnv ann) -------------------------------------------------------------------------------- getBinds = ssBinds <$> get -------------------------------------------------------------------------------- -getIter :: SolveM Int +getIter :: SolveM ann Int -------------------------------------------------------------------------------- getIter = numIter . ssStats <$> get -------------------------------------------------------------------------------- -incIter, incBrkt :: SolveM () +incIter, incBrkt :: SolveM ann () -------------------------------------------------------------------------------- incIter = modifyStats $ \s -> s {numIter = 1 + numIter s} incBrkt = modifyStats $ \s -> s {numBrkt = 1 + numBrkt s} -------------------------------------------------------------------------------- -incChck, incVald :: Int -> SolveM () +incChck, incVald :: Int -> SolveM ann () -------------------------------------------------------------------------------- incChck n = modifyStats $ \s -> s {numChck = n + numChck s} incVald n = modifyStats $ \s -> s {numVald = n + numVald s} -withContext :: (Context -> IO a) -> SolveM a +withContext :: (Context -> IO a) -> SolveM ann a withContext k = (lift . k) =<< getContext -getContext :: SolveM Context +getContext :: SolveM ann Context getContext = ssCtx <$> get -modifyStats :: (Stats -> Stats) -> SolveM () +modifyStats :: (Stats -> Stats) -> SolveM ann () modifyStats f = modify $ \s -> s { ssStats = f (ssStats s) } -------------------------------------------------------------------------------- @@ -133,12 +132,12 @@ -- -- Yields the ids of bindings known to the SMT sendConcreteBindingsToSMT - :: F.IBindEnv -> (F.IBindEnv -> SolveM a) -> SolveM a + :: F.IBindEnv -> (F.IBindEnv -> SolveM ann a) -> SolveM ann a sendConcreteBindingsToSMT known act = do be <- getBinds let concretePreds = [ (i, F.subst1 p (v, F.EVar s)) - | (i, s, F.RR _ (F.Reft (v, p))) <- F.bindEnvToList be + | (i, (s, F.RR _ (F.Reft (v, p)),_)) <- F.bindEnvToList be , F.isConc p , not (isShortExpr p) , not (F.memberIBindEnv i known) @@ -159,7 +158,7 @@ -- | `filterRequired [(x1, p1),...,(xn, pn)] q` returns a minimal list [xi] s.t. -- /\ [pi] => q -------------------------------------------------------------------------------- -filterRequired :: F.Cand a -> F.Expr -> SolveM [a] +filterRequired :: F.Cand a -> F.Expr -> SolveM ann [a] -------------------------------------------------------------------------------- filterRequired = error "TBD:filterRequired" @@ -183,10 +182,10 @@ -} -------------------------------------------------------------------------------- --- | `filterValid p [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` +-- | `filterValid p [(q1, x1),...,(qn, xn)]` returns the list `[ xi | p => qi]` -------------------------------------------------------------------------------- {-# SCC filterValid #-} -filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM [a] +filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM ann [a] -------------------------------------------------------------------------------- filterValid sp p qs = do qs' <- withContext $ \me -> @@ -215,7 +214,7 @@ -- | `filterValidGradual ps [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` -- | for some p in the list ps -------------------------------------------------------------------------------- -filterValidGradual :: [F.Expr] -> F.Cand a -> SolveM [a] +filterValidGradual :: [F.Expr] -> F.Cand a -> SolveM ann [a] -------------------------------------------------------------------------------- filterValidGradual p qs = do qs' <- withContext $ \me -> @@ -229,7 +228,7 @@ filterValidGradual_ :: [F.Expr] -> F.Cand a -> Context -> IO [a] filterValidGradual_ ps qs me - = (map snd . fst) <$> foldM partitionCandidates ([], qs) ps + = map snd . fst <$> foldM partitionCandidates ([], qs) ps where partitionCandidates :: (F.Cand a, F.Cand a) -> F.Expr -> IO (F.Cand a, F.Cand a) partitionCandidates (ok, candidates) p = do @@ -244,14 +243,14 @@ smtBracket me "filterValidRHS" $ do smtAssert me (F.PNot q) valid <- smtCheckUnsat me - return $ ((q, x), valid) + return ((q, x), valid) -smtEnablembqi :: SolveM () +smtEnablembqi :: SolveM ann () smtEnablembqi = withContext smtSetMbqi -------------------------------------------------------------------------------- -checkSat :: F.Expr -> SolveM Bool +checkSat :: F.Expr -> SolveM ann Bool -------------------------------------------------------------------------------- checkSat p = withContext $ \me -> @@ -259,20 +258,20 @@ smtCheckSat me p -------------------------------------------------------------------------------- -assumesAxioms :: [F.Triggered F.Expr] -> SolveM () +assumesAxioms :: [F.Triggered F.Expr] -> SolveM ann () -------------------------------------------------------------------------------- assumesAxioms es = withContext $ \me -> forM_ es $ smtAssertAxiom me --------------------------------------------------------------------------- -stats :: SolveM Stats +stats :: SolveM ann Stats --------------------------------------------------------------------------- stats = ssStats <$> get --------------------------------------------------------------------------- -tickIter :: Bool -> SolveM Int +tickIter :: Bool -> SolveM ann Int --------------------------------------------------------------------------- tickIter newScc = progIter newScc >> incIter >> getIter -progIter :: Bool -> SolveM () +progIter :: Bool -> SolveM ann () progIter newScc = lift $ when newScc progressTick diff --git a/src/Language/Fixpoint/Solver/PLE.hs b/src/Language/Fixpoint/Solver/PLE.hs --- a/src/Language/Fixpoint/Solver/PLE.hs +++ b/src/Language/Fixpoint/Solver/PLE.hs @@ -1,1167 +1,1218 @@ -------------------------------------------------------------------------------- --- | This module implements "Proof by Logical Evaluation" where we --- unfold function definitions if they *must* be unfolded, to strengthen --- the environments with function-definition-equalities. --- The algorithm is discussed at length in: --- --- 1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842 --- 2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf --------------------------------------------------------------------------------- - -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ExistentialQuantification #-} - -module Language.Fixpoint.Solver.PLE (instantiate) where - -import Language.Fixpoint.Types hiding (simplify) -import Language.Fixpoint.Types.Config as FC -import Language.Fixpoint.Types.Solutions (CMap) -import qualified Language.Fixpoint.Types.Visitor as Vis -import qualified Language.Fixpoint.Misc as Misc -import qualified Language.Fixpoint.Smt.Interface as SMT -import Language.Fixpoint.Defunctionalize -import qualified Language.Fixpoint.Utils.Files as Files -import qualified Language.Fixpoint.Utils.Trie as T -import Language.Fixpoint.Utils.Progress -import Language.Fixpoint.SortCheck -import Language.Fixpoint.Graph.Deps (isTarget) -import Language.Fixpoint.Solver.Sanitize (symbolEnv) -import Language.Fixpoint.Solver.Rewrite - -import Language.REST.AbstractOC as OC -import Language.REST.ExploredTerms as ET -import Language.REST.RuntimeTerm as RT -import Language.REST.OrderingConstraints.ADT (ConstraintsADT) -import Language.REST.Op -import Language.REST.SMT (withZ3, SolverHandle) - -import Control.Monad.State -import Control.Monad.Trans.Maybe -import Data.Bifunctor (second) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import qualified Data.List as L -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Maybe as Mb -import qualified Data.Text as Tx -import Debug.Trace (trace) -import Text.PrettyPrint.HughesPJ.Compat - --- Type of Ordering Constraints for REST -type OCType = ConstraintsADT - -mytracepp :: (PPrint a) => String -> a -> a -mytracepp = notracepp - -traceE :: (Expr,Expr) -> (Expr,Expr) -traceE (e,e') - | isEnabled - , e /= e' - = trace ("\n" ++ showpp e ++ " ~> " ++ showpp e') (e,e') - | otherwise - = (e,e') - where - isEnabled :: Bool - isEnabled = False - --------------------------------------------------------------------------------- --- | Strengthen Constraint Environments via PLE --------------------------------------------------------------------------------- -{-# SCC instantiate #-} -instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) -instantiate cfg fi' subcIds = do - let cs = M.filterWithKey - (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds) - (cm fi) - let t = mkCTrie (M.toList cs) -- 1. BUILD the Trie - res <- withRESTSolver $ \solver -> withProgress (1 + M.size cs) $ - withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs solver) -- 2. TRAVERSE Trie to compute InstRes - savePLEEqualities cfg fi res - return $ resSInfo cfg sEnv fi res -- 3. STRENGTHEN SInfo using InstRes - where - withRESTSolver :: (Maybe SolverHandle -> IO a) -> IO a - withRESTSolver f | null (concat $ M.elems $ aenvAutoRW aEnv) = f Nothing - withRESTSolver f | otherwise = withZ3 (\z3 -> f (Just z3)) - - file = srcFile cfg ++ ".evals" - sEnv = symbolEnv cfg fi - aEnv = ae fi - fi = normalize fi' - -savePLEEqualities :: Config -> SInfo a -> InstRes -> IO () -savePLEEqualities cfg fi res = when (save cfg) $ do - let fq = queryFile Files.Fq cfg ++ ".ple" - putStrLn $ "\nSaving PLE equalities: " ++ fq ++ "\n" - Misc.ensurePath fq - let constraint_equalities = - map equalitiesPerConstraint $ Misc.hashMapToAscList $ cm fi - writeFile fq $ render $ vcat $ - map renderConstraintRewrite constraint_equalities - where - equalitiesPerConstraint (cid, c) = - (cid, L.sort [ e | i <- elemsIBindEnv (senv c), Just e <- [M.lookup i res] ]) - renderConstraintRewrite (cid, eqs) = - "constraint id" <+> text (show cid ++ ":") - $+$ nest 2 (toFix (pAnd eqs)) - $+$ "" - -------------------------------------------------------------------------------- --- | Step 1a: @instEnv@ sets up the incremental-PLE environment -instEnv :: (Loc a) => Config -> SInfo a -> CMap (SimpC a) -> Maybe SolverHandle -> SMT.Context -> InstEnv a -instEnv cfg fi cs restSolver ctx = InstEnv cfg ctx bEnv aEnv cs γ s0 - where - bEnv = bs fi - aEnv = ae fi - γ = knowledge cfg ctx fi - s0 = EvalEnv (SMT.ctxSymEnv ctx) mempty (defFuelCount cfg) et restSolver - et = fmap makeET restSolver - makeET solver = - ET.empty (EF (OC.union (ordConstraints solver)) (OC.notStrongerThan (ordConstraints solver))) - ----------------------------------------------------------------------------------------------- --- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments --- --- The trie is a way to unfold the equalities a minimum number of times. --- Say you have --- --- > 1: [1, 2, 3, 4, 5] => p1 --- > 2: [1, 2, 3, 6, 7] => p2 --- --- Then you build the tree --- --- > 1 -> 2 -> 3 -> 4 -> 5 — [Constraint 1] --- > | -> 6 -> 7 — [Constraint 2] --- --- which you use to unfold everything in 1, 2, and 3 once (instead of twice) --- and with the proper existing environment --- -mkCTrie :: [(SubcId, SimpC a)] -> CTrie -mkCTrie ics = T.fromList [ (cBinds c, i) | (i, c) <- ics ] - where - cBinds = L.sort . elemsIBindEnv . senv - ----------------------------------------------------------------------------------------------- --- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE -pleTrie :: CTrie -> InstEnv a -> IO InstRes -pleTrie t env = loopT env ctx0 diff0 Nothing res0 t - where - diff0 = [] - res0 = M.empty - ctx0 = initCtx env ((mkEq <$> es0) ++ (mkEq' <$> es0')) - es0 = L.filter (null . eqArgs) (aenvEqs . ieAenv $ env) - es0' = L.filter (null . smArgs) (aenvSimpl . ieAenv $ env) - mkEq eq = (EVar $ eqName eq, eqBody eq) - mkEq' rw = (EApp (EVar $ smName rw) (EVar $ smDC rw), smBody rw) - -loopT - :: InstEnv a - -> ICtx - -> Diff -- ^ The longest path suffix without forks in reverse order - -> Maybe BindId -- ^ bind id of the branch ancestor of the trie if any. - -- 'Nothing' when this is the top-level trie. - -> InstRes - -> CTrie - -> IO InstRes -loopT env ctx delta i res t = case t of - T.Node [] -> return res - T.Node [b] -> loopB env ctx delta i res b - T.Node bs -> withAssms env ctx delta Nothing $ \ctx' -> do - (ctx'', res') <- ple1 env ctx' i res - foldM (loopB env ctx'' [] i) res' bs - -loopB - :: InstEnv a - -> ICtx - -> Diff -- ^ The longest path suffix without forks in reverse order - -> Maybe BindId -- ^ bind id of the branch ancestor of the branch if any. - -- 'Nothing' when this is a branch of the top-level trie. - -> InstRes - -> CBranch - -> IO InstRes -loopB env ctx delta iMb res b = case b of - T.Bind i t -> loopT env ctx (i:delta) (Just i) res t - T.Val cid -> withAssms env ctx delta (Just cid) $ \ctx' -> do - progressTick - (snd <$> ple1 env ctx' iMb res) - --- | Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@ --- and the rhs of @cidMb@. --- --- Adds to @ctx@ assumptions from @env@ and @delta@ plus rewrites that --- candidates can use. --- --- Sets the current constraint id in @ctx@ to @cidMb@. --- --- Pushes assumptions from the modified context to the SMT solver, runs @act@, --- and then pops the assumptions. --- -withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b -withAssms env@(InstEnv {..}) ctx delta cidMb act = do - let ctx' = updCtx env ctx delta cidMb - let assms = icAssms ctx' - SMT.smtBracket ieSMT "PLE.evaluate" $ do - forM_ assms (SMT.smtAssert ieSMT) - act ctx' { icAssms = mempty } - --- | @ple1@ performs the PLE at a single "node" in the Trie -ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstRes) -ple1 (InstEnv {..}) ctx i res = - updCtxRes res i <$> evalCandsLoop ieCfg ctx ieSMT ieKnowl ieEvEnv - - -evalToSMT :: String -> Config -> SMT.Context -> (Expr, Expr) -> Pred -evalToSMT msg cfg ctx (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx [] (EEq e1 e2) - -evalCandsLoop :: Config -> ICtx -> SMT.Context -> Knowledge -> EvalEnv -> IO ICtx -evalCandsLoop cfg ictx0 ctx γ env = go ictx0 0 - where - withRewrites exprs = - let - rws = [rewrite e (knSims γ) | e <- S.toList (snd `S.map` exprs)] - in - exprs <> (S.fromList $ concat rws) - go ictx _ | S.null (icCands ictx) = return ictx - go ictx i = do - let cands = icCands ictx - let env' = env { evAccum = icEquals ictx <> evAccum env - , evFuel = icFuel ictx - } - (ictx', evalResults) <- do - SMT.smtAssert ctx (pAndNoDedup (S.toList $ icAssms ictx)) - let ictx' = ictx { icAssms = mempty } - foldM (evalOneCandStep γ env' i) (ictx', []) (S.toList cands) - -- foldM (\ictx e -> undefined) - -- mapM (evalOne γ env' ictx) (S.toList cands) - let us = mconcat evalResults - if S.null (us `S.difference` icEquals ictx) - then return ictx - else do let oks = fst `S.map` us - let us' = withRewrites us - let eqsSMT = evalToSMT "evalCandsLoop" cfg ctx `S.map` us' - let ictx'' = ictx' { icSolved = icSolved ictx <> oks - , icEquals = icEquals ictx <> us' - , icAssms = S.filter (not . isTautoPred) eqsSMT } - let newcands = mconcat (makeCandidates γ ictx'' <$> S.toList (cands <> (snd `S.map` us))) - go (ictx'' { icCands = S.fromList newcands}) (i + 1) - -evalOneCandStep :: Knowledge -> EvalEnv -> Int -> (ICtx, [EvAccum]) -> Expr -> IO (ICtx, [EvAccum]) -evalOneCandStep γ env' i (ictx, acc) e = do - (res, fm) <- evalOne γ env' ictx i e - return (ictx { icFuel = fm}, res : acc) - -rewrite :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)] -rewrite e rwEnv = concat $ map (`rewriteTop` rwEnv) (notGuardedApps e) - -rewriteTop :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)] -rewriteTop e rwEnv = - [ (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw)) - | (EVar f, es) <- [splitEApp e] - , Just rws <- [Map.lookup f rwEnv] - , rw <- rws - , length es == length (smArgs rw) - ] - ----------------------------------------------------------------------------------------------- --- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo ----------------------------------------------------------------------------------------------- - -resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a -resSInfo cfg env fi res = strengthenBinds fi res' - where - res' = M.fromList $ zip is ps'' - ps'' = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' - ps' = defuncAny cfg env ps - (is, ps) = unzip (M.toList res) - ----------------------------------------------------------------------------------------------- --- | @InstEnv@ has the global information needed to do PLE ----------------------------------------------------------------------------------------------- - -data InstEnv a = InstEnv - { ieCfg :: !Config - , ieSMT :: !SMT.Context - , ieBEnv :: !BindEnv - , ieAenv :: !AxiomEnv - , ieCstrs :: !(CMap (SimpC a)) - , ieKnowl :: !Knowledge - , ieEvEnv :: !EvalEnv - } - ----------------------------------------------------------------------------------------------- --- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE ----------------------------------------------------------------------------------------------- - -data ICtx = ICtx - { icAssms :: S.HashSet Pred -- ^ Equalities converted to SMT format - , icCands :: S.HashSet Expr -- ^ "Candidates" for unfolding - , icEquals :: EvAccum -- ^ Accumulated equalities - , icSolved :: S.HashSet Expr -- ^ Terms that we have already expanded - , icSimpl :: !ConstMap -- ^ Map of expressions to constants - , icSubcId :: Maybe SubcId -- ^ Current subconstraint ID - , icFuel :: !FuelCount -- ^ Current fuel-count - , icANFs :: S.HashSet Pred -- Hopefully contain only ANF things - } - ----------------------------------------------------------------------------------------------- --- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId ----------------------------------------------------------------------------------------------- - -type InstRes = M.HashMap BindId Expr - ----------------------------------------------------------------------------------------------- --- | @Unfold is the result of running PLE at a single equality; --- (e, [(e1, e1')...]) is the source @e@ and the (possible empty) --- list of PLE-generated equalities (e1, e1') ... ----------------------------------------------------------------------------------------------- - -type CTrie = T.Trie SubcId -type CBranch = T.Branch SubcId -type Diff = [BindId] -- ^ in "reverse" order - -initCtx :: InstEnv a -> [(Expr,Expr)] -> ICtx -initCtx env es = ICtx - { icAssms = mempty - , icCands = mempty - , icEquals = S.fromList es - , icSolved = mempty - , icSimpl = mempty - , icSubcId = Nothing - , icFuel = evFuel (ieEvEnv env) - , icANFs = mempty - } - -equalitiesPred :: S.HashSet (Expr, Expr) -> [Expr] -equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- S.toList eqs, e1 /= e2 ] - -updCtxRes :: InstRes -> Maybe BindId -> ICtx -> (ICtx, InstRes) -updCtxRes res iMb ctx = (ctx, res') - where - res' = updRes res iMb (pAnd $ equalitiesPred $ icEquals ctx) - - -updRes :: InstRes -> Maybe BindId -> Expr -> InstRes -updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res -updRes res Nothing _ = res - ----------------------------------------------------------------------------------------------- --- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ --- to the context. ----------------------------------------------------------------------------------------------- - -updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx -updCtx InstEnv {..} ctx delta cidMb - = ctx { icAssms = S.fromList (filter (not . isTautoPred) ctxEqs) - , icCands = S.fromList cands <> icCands ctx - , icEquals = initEqs <> icEquals ctx - , icSimpl = M.fromList (S.toList sims) <> icSimpl ctx <> econsts - , icSubcId = cidMb - , icANFs = anfs <> icANFs ctx - } - where - initEqs = S.fromList $ concat [rewrite e (knSims ieKnowl) | e <- cands] - anfs = S.fromList (toSMT "updCtx" ieCfg ieSMT [] <$> L.nub [ expr xr | xr <- bs ]) - cands = concatMap (makeCandidates ieKnowl ctx) (rhs:es) - sims = S.filter (isSimplification (knDCs ieKnowl)) (initEqs <> icEquals ctx) - econsts = M.fromList $ findConstants ieKnowl es - ctxEqs = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub (concat - [ equalitiesPred initEqs - , equalitiesPred sims - , equalitiesPred (icEquals ctx) - , [ expr xr | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ] - ]) - bs = second unElabSortedReft <$> binds - (rhs:es) = unElab <$> (eRhs : (expr <$> binds)) - eRhs = maybe PTrue crhs subMb - binds = [ lookupBindEnv i ieBEnv | i <- delta ] - subMb = getCstr ieCstrs <$> cidMb - - -findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)] -findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)] - where - go su ess = if ess == ess' - then su - else go (su ++ su') ess' - where ess' = subst (mkSubst su') <$> ess - su' = makeSu ess - makeSu exprs = [(x,c) | (EEq (EVar x) c) <- exprs - , isConstant (knDCs γ) c - , EVar x /= c ] - -makeCandidates :: Knowledge -> ICtx -> Expr -> [Expr] -makeCandidates γ ctx expr - = mytracepp ("\n" ++ show (length cands) ++ " New Candidates") cands - where - cands = filter (\e -> isRedex γ e && not (e `S.member` icSolved ctx)) (notGuardedApps expr) - -isRedex :: Knowledge -> Expr -> Bool -isRedex γ e = isGoodApp γ e || isIte e - where - isIte EIte {} = True - isIte _ = False - - -isGoodApp :: Knowledge -> Expr -> Bool -isGoodApp γ e - | (EVar f, es) <- splitEApp e - , Just i <- L.lookup f (knSummary γ) - = length es >= i - | otherwise - = False - - - - -getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a -getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env - -isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool -isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) - -type EvAccum = S.HashSet (Expr, Expr) - --------------------------------------------------------------------------------- -data EvalEnv = EvalEnv - { evEnv :: !SymEnv - , evAccum :: EvAccum - , evFuel :: FuelCount - - -- REST parameters - , explored :: Maybe (ExploredTerms RuntimeTerm (OCType Op) IO) - , restSolver :: Maybe SolverHandle - } - -data FuelCount = FC - { fcMap :: M.HashMap Symbol Int - , fcMax :: Maybe Int - } - deriving (Show) - -defFuelCount :: Config -> FuelCount -defFuelCount cfg = FC mempty (fuel cfg) - -type EvalST a = StateT EvalEnv IO a --------------------------------------------------------------------------------- - - -getAutoRws :: Knowledge -> ICtx -> [AutoRewrite] -getAutoRws γ ctx = - Mb.fromMaybe [] $ do - cid <- icSubcId ctx - M.lookup cid $ knAutoRWs γ - -evalOne :: Knowledge -> EvalEnv -> ICtx -> Int -> Expr -> IO (EvAccum, FuelCount) -evalOne γ env ctx i e | i > 0 || null (getAutoRws γ ctx) = do - ((e', _), st) <- runStateT (eval γ ctx NoRW e) (env { evFuel = icFuel ctx }) - let evAcc' = if (mytracepp ("evalOne: " ++ showpp e) e') == e then evAccum st else S.insert (e, e') (evAccum st) - return (evAcc', evFuel st) -evalOne γ env ctx _ e | otherwise = do - env' <- execStateT (evalREST γ ctx rp) (env { evFuel = icFuel ctx }) - return (evAccum env', evFuel env') - where - oc :: AbstractOC (OCType Op) Expr IO - oc = ordConstraints (Mb.fromJust $ restSolver env) - - rp = RP oc [(e, PLE)] constraints - constraints = foldl go (OC.top oc) [] - where - go c (t, u) = refine oc c t u - - --- | @notGuardedApps e@ yields all the subexpressions that are --- applications not under an if-then-else, lambda abstraction, type abstraction, --- type application, or quantifier. -notGuardedApps :: Expr -> [Expr] -notGuardedApps = go - where - go e@(EApp e1 e2) = [e] ++ go e1 ++ go e2 - go (PAnd es) = concatMap go es - go (POr es) = concatMap go es - go (PAtom _ e1 e2) = go e1 ++ go e2 - go (PIff e1 e2) = go e1 ++ go e2 - go (PImp e1 e2) = go e1 ++ go e2 - go (EBin _ e1 e2) = go e1 ++ go e2 - go (PNot e) = go e - go (ENeg e) = go e - go e@(EIte b _ _) = go b ++ [e] -- ++ go e1 ++ go e2 - go (ECoerc _ _ e) = go e - go (ECst e _) = go e - go (ESym _) = [] - go (ECon _) = [] - go (EVar _) = [] - go (ELam _ _) = [] - go (ETApp _ _) = [] - go (ETAbs _ _) = [] - go (PKVar _ _) = [] - go (PAll _ _) = [] - go (PExist _ _) = [] - go (PGrad{}) = [] - - - --- The FuncNormal and RWNormal evaluation strategies are used for REST --- For example, consider the following function: --- add(x, y) = if x == 0 then y else add(x - 1, y + 1) --- And a rewrite rule: --- forall a, b . add(a,b) -> add(b, a) --- Then the expression add(t, add(2, 1)) would evaluate under NoRW to: --- if t == 0 then 3 else add(t - 1, 4) --- However, under FuncNormal, it would evaluate to: add(t, 3) --- Thus, FuncNormal could engage the rewrite rule add(t, 3) = add(3, t) - - -data EvalType = - NoRW -- Normal PLE - | FuncNormal -- REST: Expand function definitions only when the branch can be decided - | RWNormal -- REST: Fully Expand Defs in the context of rewriting (similar to NoRW) - deriving (Eq) - --- Indicates whether or not the evaluation has expanded a function statement --- into a conditional branch. --- In this case, rewriting should stop --- It's unclear whether or not rewriting in either branch makes sense, --- since one branch could be an ill-formed expression. -newtype FinalExpand = FE Bool deriving (Show) - -noExpand :: FinalExpand -noExpand = FE False - -expand :: FinalExpand -expand = FE True - -mapFE :: (Expr -> Expr) -> (Expr, FinalExpand) -> (Expr, FinalExpand) -mapFE f (e, fe) = (f e, fe) - -feVal :: FinalExpand -> Bool -feVal (FE f) = f - -feAny :: [FinalExpand] -> FinalExpand -feAny xs = FE $ any id (map feVal xs) - -(<|>) :: FinalExpand -> FinalExpand -> FinalExpand -(<|>) (FE True) _ = expand -(<|>) _ f = f - - -feSeq :: [(Expr, FinalExpand)] -> ([Expr], FinalExpand) -feSeq xs = (map fst xs, feAny (map snd xs)) - --- | Unfolds expressions using rewrites and equations. --- --- Also reduces if-then-else when the boolean condition or the negation can be --- proved valid. This is the actual implementation of guard-validation-before-unfolding --- that is described in publications. --- --- Also folds constants. --- --- Also adds to the monad state all the subexpressions that have been rewritten --- as pairs @(original_subexpression, rewritten_subexpression)@. --- -eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand) -eval _ ctx _ e - | Just v <- M.lookup e (icSimpl ctx) - = return (v, noExpand) - -eval γ ctx et e = - do acc <- gets (S.toList . evAccum) - case L.lookup e acc of - -- If rewriting, don't lookup, as evAccum may contain loops - Just e' | null (getAutoRws γ ctx) -> eval γ ctx et e' - _ -> do - (e0', fe) <- go e - let e' = simplify γ ctx e0' - if e /= e' - then - case et of - NoRW -> do - modify (\st -> st { evAccum = S.insert (traceE (e, e')) (evAccum st) }) - (e'', fe') <- eval γ (addConst (e,e') ctx) et e' - return (e'', fe <|> fe') - _ -> return (e', fe) - else - return (e, fe) - where - addConst (e,e') ctx = if isConstant (knDCs γ) e' - then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx - go (ELam (x,s) e) = mapFE (ELam (x, s)) <$> eval γ' ctx et e where γ' = γ { knLams = (x, s) : knLams γ } - go (EIte b e1 e2) = evalIte γ ctx et b e1 e2 - go (ECoerc s t e) = mapFE (ECoerc s t) <$> go e - go e@(EApp _ _) = - case splitEApp e of - (f, es) | et == RWNormal -> - -- Just evaluate the arguments first, to give rewriting a chance to step in - -- if necessary - do - (es', fe) <- feSeq <$> mapM (eval γ ctx et) es - r <- if es /= es' - then return (eApps f es', fe) - else do - (f', fe) <- eval γ ctx et f - (e', fe') <- evalApp γ ctx f' es et - return $ (e', fe <|> fe') - return r - (f, es) -> - do - ((f':es'), fe) <- feSeq <$> mapM (eval γ ctx et) (f:es) - (e', fe') <- evalApp γ ctx f' es' et - return $ (e', fe <|> fe') - - go e@(PAtom r e1 e2) = evalBoolOr e (binOp (PAtom r) e1 e2) - go (ENeg e) = do (e', fe) <- eval γ ctx et e - return $ ((ENeg e'), fe) - go (EBin o e1 e2) = do (e1', fe1) <- eval γ ctx et e1 - (e2', fe2) <- eval γ ctx et e2 - return (EBin o e1' e2', fe1 <|> fe2) - go (ETApp e t) = mapFE (flip ETApp t) <$> go e - go (ETAbs e s) = mapFE (flip ETAbs s) <$> go e - go e@(PNot e') = evalBoolOr e (mapFE PNot <$> go e') - go e@(PImp e1 e2) = evalBoolOr e (binOp PImp e1 e2) - go e@(PIff e1 e2) = evalBoolOr e (binOp PIff e1 e2) - go e@(PAnd es) = evalBoolOr e (efAll PAnd (go <$$> es)) - go e@(POr es) = evalBoolOr e (efAll POr (go <$$> es)) - go e = return (e, noExpand) - - binOp f e1 e2 = do - (e1', fe1) <- go e1 - (e2', fe2) <- go e2 - return (f e1' e2', fe1 <|> fe2) - - efAll f mes = do - xs <- mes - let (xs', fe) = feSeq xs - return (f xs', fe) - - evalBoolOr :: Expr -> EvalST (Expr, FinalExpand) -> EvalST (Expr, FinalExpand) - evalBoolOr ee fallback = do - b <- evalBool γ ee - case b of - Just r -> return (r, noExpand) - Nothing -> fallback - -data RESTParams oc = RP - { oc :: AbstractOC oc Expr IO - , path :: [(Expr, TermOrigin)] - , c :: oc - } - -getANFSubs :: Expr -> [(Symbol, Expr)] -getANFSubs (PAnd es) = concatMap getANFSubs es -getANFSubs (EEq lhs rhs) | (EVar v) <- unElab lhs - , anfPrefix `isPrefixOfSym` v = [(v, unElab rhs)] -getANFSubs (EEq lhs rhs) | (EVar v) <- unElab rhs - , anfPrefix `isPrefixOfSym` v = [(v, unElab lhs)] -getANFSubs _ = [] - --- Reverse the ANF transformation -deANF :: ICtx -> Expr -> Expr -deANF ctx e = subst' e where - ints = concatMap getANFSubs (S.toList $ icANFs ctx) - ints' = map go (L.groupBy (\x y -> fst x == fst y) $ L.sortOn fst $ L.nub ints) where - go ([(t, u)]) = (t, u) - go ts = (fst (head ts), getBest (map snd ts)) - su = Su (M.fromList ints') - subst' ee = - let - ee' = subst su ee - in - if ee == ee' - then ee - else subst' ee' - - getBest ts | Just t <- L.find isVar ts = t - where - -- Hack : Vars starting with ds_ are probably constants - isVar (EVar t) = not $ Tx.isPrefixOf "ds_" (symbolText t) - isVar _ = False - - -- If the only match is a ds_ var, use it - getBest ts | Just t <- L.find isVar ts = t - where - isVar (EVar _) = True - isVar _ = False - - getBest ts | otherwise = head ts - --- | --- Adds to the monad state all the subexpressions that have been rewritten --- as pairs @(original_subexpression, rewritten_subexpression)@. --- --- Also folds constants. --- --- The main difference with 'eval' is that 'evalREST' takes into account --- autorewrites. --- -evalREST :: Knowledge -> ICtx -> RESTParams (OCType Op) -> EvalST () -evalREST _ ctx rp - | pathExprs <- map fst (mytracepp "EVAL1: path" $ path rp) - , e <- last pathExprs - , Just v <- M.lookup e (icSimpl ctx) - = when (v /= e) $ modify (\st -> st { evAccum = S.insert (e, v) (evAccum st)}) - -evalREST γ ctx rp = - do - Just exploredTerms <- gets explored - se <- liftIO (shouldExploreTerm exploredTerms e) - when se $ do - possibleRWs <- getRWs - rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed) possibleRWs - (e', FE fe) <- do - r@(ec, _) <- eval γ ctx FuncNormal e - if ec /= e - then return r - else eval γ ctx RWNormal e - - let evalIsNewExpr = e' `L.notElem` pathExprs - let exprsToAdd = [e' | evalIsNewExpr] ++ map fst rws - let evAccum' = S.fromList $ map (e,) $ exprsToAdd - - modify (\st -> - st { - evAccum = S.union evAccum' (evAccum st) - , explored = Just $ ET.insert - (convert e) - (c rp) - (S.insert (convert e') $ S.fromList (map (convert . fst) possibleRWs)) - (Mb.fromJust $ explored st) - }) - - when evalIsNewExpr $ - if fe && any isRW (path rp) - then eval γ (addConst (e, e')) NoRW e' >> return () - else evalREST γ (addConst (e, e')) (rpEval e') - - mapM_ (\rw -> evalREST γ ctx (rpRW rw)) rws - where - shouldExploreTerm et e = - case rwTerminationOpts rwArgs of - RWTerminationCheckDisabled -> return $ not $ visited (convert e) et - RWTerminationCheckEnabled -> shouldExplore (convert e) (c rp) et - - allowed (rwE, _) | rwE `elem` pathExprs = return False - allowed (_, c) | otherwise = termCheck c - termCheck c = passesTerminationCheck (oc rp) rwArgs c - - notVisitedFirst et rws = - let - (v, nv) = L.partition (\(e, _) -> visited (convert e) et) rws - in - nv ++ v - - rpEval e' = - let - c' = - if any isRW (path rp) - then refine (oc rp) (c rp) e e' - else c rp - - in - rp{path = path rp ++ [(e', PLE)], c = c'} - - isRW (_, r) = r == RW - - rpRW (e', c') = rp{path = path rp ++ [(e', RW)], c = c' } - - pathExprs = map fst (mytracepp "EVAL2: path" $ path rp) - e = last pathExprs - autorws = getAutoRws γ ctx - - rwArgs = RWArgs (isValid γ) $ knRWTerminationOpts γ - - getRWs = - do - ok <- if (isRW $ last (path rp)) then (return True) else (liftIO $ termCheck (c rp)) - if ok - then - do - let e' = deANF ctx e - let getRW e ar = getRewrite (oc rp) rwArgs (c rp) e ar - let getRWs' s = Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRW s) autorws - concat <$> mapM getRWs' (subExprs e') - else return [] - - addConst (e,e') = if isConstant (knDCs γ) e' - then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx - -(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b] -f <$$> xs = f Misc.<$$> xs - - --- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites --- and equations -evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Expr, FinalExpand) -evalApp γ ctx (EVar f) es et - | Just eq <- Map.lookup f (knAms γ) - , length (eqArgs eq) <= length es - = do - env <- gets (seSort . evEnv) - okFuel <- checkFuel f - if okFuel && et /= FuncNormal - then do - useFuel f - let (es1,es2) = splitAt (length (eqArgs eq)) es - shortcut (substEq env eq es1) es2 -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter - else return $ (eApps (EVar f) es, noExpand) - where - shortcut (EIte i e1 e2) es2 = do - (b, _) <- eval γ ctx et i - b' <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValid γ b) - nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (i, PNot b)) <$> isValid γ (PNot b)) - r <- if b' - then shortcut e1 es2 - else if nb' then shortcut e2 es2 - else return $ (eApps (EIte b e1 e2) es2, expand) - return r - shortcut e' es2 = return $ (eApps e' es2, noExpand) - -evalApp γ _ (EVar f) (e:es) _ - | (EVar dc, as) <- splitEApp e - , Just rws <- Map.lookup dc (knSims γ) - , Just rw <- L.find (\rw -> smName rw == f) rws - , length as == length (smArgs rw) - = return (eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es, noExpand) - -evalApp _ _ e es _ - = return $ (eApps e es, noExpand) - --------------------------------------------------------------------------------- --- | 'substEq' unfolds or instantiates an equation at a particular list of --- argument values. We must also substitute the sort-variables that appear --- as coercions. See tests/proof/ple1.fq --------------------------------------------------------------------------------- -substEq :: SEnv Sort -> Equation -> [Expr] -> Expr -substEq env eq es = subst su (substEqCoerce env eq es) - where su = mkSubst $ zip (eqArgNames eq) es - -substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr -substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq - where - ts = snd <$> eqArgs eq - sp = panicSpan "mkCoSub" - eTs = sortExpr sp env <$> es - coSub = mkCoSub env eTs ts - -mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub -mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] - where - unite ts = Mb.fromMaybe (uError ts) (unifyTo1 senv ts) - senv = mkSearchEnv env - uError ts = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) - xys = Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs - (_xTs,_eTs) = (xTs, eTs) - -matchSorts :: Sort -> Sort -> [(Symbol, Sort)] -matchSorts s1 s2 = go s1 s2 - where - go (FObj x) {-FObj-} y = [(x, y)] - go (FAbs _ t1) (FAbs _ t2) = go t1 t2 - go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2 - go (FApp s1 t1) (FApp s2 t2) = go s1 s2 ++ go t1 t2 - go _ _ = [] - --------------------------------------------------------------------------------- - -eqArgNames :: Equation -> [Symbol] -eqArgNames = map fst . eqArgs - -evalBool :: Knowledge -> Expr -> EvalST (Maybe Expr) -evalBool γ e = do - bt <- liftIO $ isValid γ e - if bt then return $ Just PTrue - else do - bf <- liftIO $ isValid γ (PNot e) - if bf then return $ Just PFalse - else return Nothing - -evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> Expr -> Expr -> EvalST (Expr, FinalExpand) -evalIte γ ctx et b0 e1 e2 = do - (b, fe) <- eval γ ctx et b0 - b' <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp b) <$> isValid γ b) - nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (PNot b)) <$> isValid γ (PNot b)) - if b' - then return (e1, noExpand) - else if nb' then return $ (e2, noExpand) - else return $ (EIte b e1 e2, fe) - --------------------------------------------------------------------------------- --- | Knowledge (SMT Interaction) --------------------------------------------------------------------------------- -data Knowledge = KN - { knSims :: Map Symbol [Rewrite] -- ^ Rewrites rules came from match and data type definitions - -- They are grouped by the data constructor that they unfold - , knAms :: Map Symbol Equation -- ^ All function definitions - , knContext :: SMT.Context - , knPreds :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool - , knLams :: ![(Symbol, Sort)] - , knSummary :: ![(Symbol, Int)] -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity - , knDCs :: !(S.HashSet Symbol) -- ^ data constructors drawn from Rewrite - , knSels :: !SelectorMap - , knConsts :: !ConstDCMap - , knAutoRWs :: M.HashMap SubcId [AutoRewrite] - , knRWTerminationOpts :: RWTerminationOpts - } - -isValid :: Knowledge -> Expr -> IO Bool -isValid γ e = do - contra <- knPreds γ (knContext γ) (knLams γ) PFalse - if contra - then return False - else knPreds γ (knContext γ) (knLams γ) e - -knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge -knowledge cfg ctx si = KN - { knSims = Map.fromListWith (++) [ (smDC rw, [rw]) | rw <- sims] - , knAms = Map.fromList [(eqName eq, eq) | eq <- aenvEqs aenv] - , knContext = ctx - , knPreds = askSMT cfg - , knLams = [] - , knSummary = ((\s -> (smName s, 1)) <$> sims) - ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv) - ++ rwSyms - , knDCs = S.fromList (smDC <$> sims) - , knSels = Mb.catMaybes $ map makeSel sims - , knConsts = Mb.catMaybes $ map makeCons sims - , knAutoRWs = aenvAutoRW aenv - , knRWTerminationOpts = - if (rwTerminationCheck cfg) - then RWTerminationCheckEnabled - else RWTerminationCheckDisabled - } - where - sims = aenvSimpl aenv - aenv = ae si - - inRewrites :: Symbol -> Bool - inRewrites e = - let - syms = Mb.catMaybes $ map (lhsHead . arLHS) $ concat $ M.elems $ aenvAutoRW aenv - in - e `L.elem` syms - - lhsHead :: Expr -> Maybe Symbol - lhsHead e | (EVar f, _) <- splitEApp e = Just f - lhsHead _ | otherwise = Nothing - - - rwSyms = filter (inRewrites . fst) $ map toSum (toListSEnv (gLits si)) - where - toSum (sym, sort) = (sym, getArity sort) - - getArity (FFunc _ rhs) = 1 + getArity rhs - getArity _ = 0 - - - - makeCons rw - | null (syms $ smBody rw) - = Just (smName rw, (smDC rw, smBody rw)) - | otherwise - = Nothing - - makeSel rw - | EVar x <- smBody rw - = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw) - | otherwise - = Nothing - -askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool -askSMT cfg ctx bs e --- | isContraPred e = return False - | isTautoPred e = return True - | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e' - | otherwise = return False - where - e' = toSMT "askSMT" cfg ctx bs e - -toSMT :: String -> Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred -toSMT msg cfg ctx bs e = defuncAny cfg senv . elaborate "makeKnowledge" (elabEnv bs) . mytracepp ("toSMT from " ++ msg ++ showpp e) - $ e - where - elabEnv = insertsSymEnv senv - senv = SMT.ctxSymEnv ctx - - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - -withCtx :: Config -> FilePath -> SymEnv -> (SMT.Context -> IO a) -> IO a -withCtx cfg file env k = do - ctx <- SMT.makeContextWithSEnv cfg file env - _ <- SMT.smtPush ctx - res <- k ctx - _ <- SMT.cleanupContext ctx - return res - - --- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi, --- i.e., sel_i selects the ith value for the data constructor D -type SelectorMap = [(Symbol, (Symbol, Int))] -type ConstDCMap = [(Symbol, (Symbol, Expr))] - --- ValueMap maps expressions to constants (including data constructors) -type ConstMap = M.HashMap Expr Expr -type LDataCon = Symbol -- Data Constructors - -isSimplification :: S.HashSet LDataCon -> (Expr,Expr) -> Bool -isSimplification dcs (_,c) = isConstant dcs c - - -isConstant :: S.HashSet LDataCon -> Expr -> Bool -isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs) - -class Simplifiable a where - simplify :: Knowledge -> ICtx -> a -> a - - -instance Simplifiable Expr where - simplify γ ictx e = mytracepp ("simplification of " ++ showpp e) $ fix (Vis.mapExprOnExpr tx) e - where - fix f e = if e == e' then e else fix f e' where e' = f e - tx e - | Just e' <- M.lookup e (icSimpl ictx) - = e' - tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2 - tx (ENeg e) = applyConstantFolding Minus (ECon (I 0)) e - tx (EApp (EVar f) a) - | Just (dc, c) <- L.lookup f (knConsts γ) - , (EVar dc', _) <- splitEApp a - , dc == dc' - = c - tx (EIte b e1 e2) - | isTautoPred b = e1 - | isContraPred b = e2 - tx (ECoerc s t e) - | s == t = e - tx (EApp (EVar f) a) - | Just (dc, i) <- L.lookup f (knSels γ) - , (EVar dc', es) <- splitEApp a - , dc == dc' - = es!!i - tx e = e - -applyConstantFolding :: Bop -> Expr -> Expr -> Expr -applyConstantFolding bop e1 e2 = - case (e1, e2) of - ((ECon (R left)), (ECon (R right))) -> - Mb.fromMaybe e (cfR bop left right) - ((ECon (R left)), (ECon (I right))) -> - Mb.fromMaybe e (cfR bop left (fromIntegral right)) - ((ECon (I left)), (ECon (R right))) -> - Mb.fromMaybe e (cfR bop (fromIntegral left) right) - ((ECon (I left)), (ECon (I right))) -> - Mb.fromMaybe e (cfI bop left right) - _ -> e - where - - e = EBin bop e1 e2 - - getOp :: Num a => Bop -> Maybe (a -> a -> a) - getOp Minus = Just (-) - getOp Plus = Just (+) - getOp Times = Just (*) - getOp RTimes = Just (*) - getOp _ = Nothing - - cfR :: Bop -> Double -> Double -> Maybe Expr - cfR bop left right = fmap go (getOp' bop) - where - go f = ECon $ R $ f left right - - getOp' Div = Just (/) - getOp' RDiv = Just (/) - getOp' op = getOp op - - cfI :: Bop -> Integer -> Integer -> Maybe Expr - cfI bop left right = fmap go (getOp' bop) - where - go f = ECon $ I $ f left right - - getOp' Mod = Just mod - getOp' op = getOp op - - -------------------------------------------------------------------------------- --- | Normalization of Equation: make their arguments unique ------------------- -------------------------------------------------------------------------------- - -class Normalizable a where - normalize :: a -> a - -instance Normalizable (GInfo c a) where - normalize si = si {ae = normalize $ ae si} - -instance Normalizable AxiomEnv where - normalize aenv = aenv { aenvEqs = mytracepp "aenvEqs" (normalize <$> aenvEqs aenv) - , aenvSimpl = mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) } - -instance Normalizable Rewrite where - normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw } - where - su = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs' - xs = smArgs rw - xs' = zipWith mkSymbol xs [0..] - mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i - - -instance Normalizable Equation where - normalize eq = eq {eqArgs = zip xs' ss, eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq } - where - su = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs' - (xs,ss) = unzip (eqArgs eq) - xs' = zipWith mkSymbol xs [0..] - mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i - - -normalizeBody :: Symbol -> Expr -> Expr -normalizeBody f = go - where - go e - | any (== f) (syms e) - = go' e - go e - = e - - go' (PAnd [PImp c e1,PImp (PNot c') e2]) - | c == c' = EIte c e1 (go' e2) - go' e = e - -_splitBranches :: Symbol -> Expr -> [(Expr, Expr)] -_splitBranches f = go - where - go (PAnd es) - | any (== f) (syms es) - = go' <$> es - go e - = [(PTrue, e)] - - go' (PImp c e) = (c, e) - go' e = (PTrue, e) - --- -- TODO:FUEL Config --- maxFuel :: Int --- maxFuel = 11 - -useFuel :: Symbol -> EvalST () -useFuel f = do - modify (\st -> st { evFuel = useFuelCount f (evFuel st) }) - -useFuelCount :: Symbol -> FuelCount -> FuelCount -useFuelCount f fc = fc { fcMap = M.insert f (k + 1) m } - where - k = M.lookupDefault 0 f m - m = fcMap fc - -checkFuel :: Symbol -> EvalST Bool -checkFuel f = do +-- | This module implements "Proof by Logical Evaluation" where we +-- unfold function definitions if they *must* be unfolded, to strengthen +-- the environments with function-definition-equalities. +-- The algorithm is discussed at length in: +-- +-- 1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842 +-- 2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf +-------------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Language.Fixpoint.Solver.PLE + ( instantiate + + -- The following exports are for property testing. + , FuelCount(..) + , ICtx(..) + , Knowledge(..) + , simplify + ) + where + +import Language.Fixpoint.Types hiding (simplify) +import Language.Fixpoint.Types.Config as FC +import Language.Fixpoint.Types.Solutions (CMap) +import qualified Language.Fixpoint.Types.Visitor as Vis +import qualified Language.Fixpoint.Misc as Misc +import qualified Language.Fixpoint.Smt.Interface as SMT +import Language.Fixpoint.Defunctionalize +import Language.Fixpoint.Solver.EnvironmentReduction (inlineInExpr, undoANF) +import qualified Language.Fixpoint.Utils.Files as Files +import qualified Language.Fixpoint.Utils.Trie as T +import Language.Fixpoint.Utils.Progress +import Language.Fixpoint.SortCheck +import Language.Fixpoint.Graph.Deps (isTarget) +import Language.Fixpoint.Solver.Common (askSMT, toSMT) +import Language.Fixpoint.Solver.Sanitize (symbolEnv) +import Language.Fixpoint.Solver.Simplify +import Language.Fixpoint.Solver.Rewrite as Rewrite + +import Language.REST.OCAlgebra as OC +import Language.REST.ExploredTerms as ExploredTerms +import Language.REST.RuntimeTerm as RT +import Language.REST.SMT (withZ3, SolverHandle) + +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.Bifunctor (second) +import qualified Data.HashMap.Strict as M +import qualified Data.HashMap.Lazy as HashMap.Lazy +import qualified Data.HashSet as S +import Data.IORef +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Mb +import qualified Data.Set as Set +import Text.PrettyPrint.HughesPJ.Compat + +mytracepp :: (PPrint a) => String -> a -> a +mytracepp = notracepp + +-------------------------------------------------------------------------------- +-- | Strengthen Constraint Environments via PLE +-------------------------------------------------------------------------------- +{-# SCC instantiate #-} +instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) +instantiate cfg fi' subcIds = do + let cs = M.filterWithKey + (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds) + (cm fi) + let t = mkCTrie (M.toList cs) -- 1. BUILD the Trie + res <- withRESTSolver $ \solver -> withProgress (1 + M.size cs) $ + withCtx cfg file sEnv $ \ctx -> do + env <- instEnv cfg fi cs solver ctx + pleTrie t env -- 2. TRAVERSE Trie to compute InstRes + savePLEEqualities cfg fi sEnv res + return $ resSInfo cfg sEnv fi res -- 3. STRENGTHEN SInfo using InstRes + where + withRESTSolver :: (Maybe SolverHandle -> IO a) -> IO a + withRESTSolver f | all null (M.elems $ aenvAutoRW aEnv) = f Nothing + withRESTSolver f = withZ3 (f . Just) + + file = srcFile cfg ++ ".evals" + sEnv = symbolEnv cfg fi + aEnv = ae fi + fi = normalize fi' + +savePLEEqualities :: Config -> SInfo a -> SymEnv -> InstRes -> IO () +savePLEEqualities cfg fi sEnv res = when (save cfg) $ do + let fq = queryFile Files.Fq cfg ++ ".ple" + putStrLn $ "\nSaving PLE equalities: " ++ fq ++ "\n" + Misc.ensurePath fq + let constraint_equalities = + map equalitiesPerConstraint $ Misc.hashMapToAscList $ cm fi + writeFile fq $ render $ vcat $ + map renderConstraintRewrite constraint_equalities + where + equalitiesPerConstraint (cid, c) = + (cid, L.sort [ e | i <- elemsIBindEnv (senv c), Just e <- [M.lookup i res] ]) + renderConstraintRewrite (cid, eqs) = + "constraint id" <+> text (show cid ++ ":") + $+$ nest 2 + (vcat $ L.intersperse "" $ + map (toFix . unElab) $ Set.toList $ Set.fromList $ + -- call elabExpr to try to bring equations that are missing + -- some casts into a fully annotated form for comparison + map (elabExpr "savePLEEqualities" sEnv) $ + concatMap conjuncts eqs + ) + $+$ "" + +------------------------------------------------------------------------------- +-- | Step 1a: @instEnv@ sets up the incremental-PLE environment +instEnv :: (Loc a) => Config -> SInfo a -> CMap (SimpC a) -> Maybe SolverHandle -> SMT.Context -> IO (InstEnv a) +instEnv cfg fi cs restSolver ctx = do + refRESTCache <- newIORef mempty + refRESTSatCache <- newIORef mempty + let + restOC = FC.restOC cfg + oc0 = ordConstraints restOC $ Mb.fromJust restSolver + oc :: OCAlgebra OCType RuntimeTerm IO + oc = oc0 + { OC.isSat = cachedIsSat refRESTSatCache oc0 + , OC.notStrongerThan = cachedNotStrongerThan refRESTCache oc0 + } + et :: ExploredTerms RuntimeTerm OCType IO + et = ExploredTerms.empty + EF + { ExploredTerms.union = OC.union oc + , ExploredTerms.subsumes = OC.notStrongerThan oc + , exRefine = OC.refine oc + } + ExploreWhenNeeded + s0 = EvalEnv + { evEnv = SMT.ctxSymEnv ctx + , evPendingUnfoldings = mempty + , evNewEqualities = mempty + , evSMTCache = mempty + , evFuel = defFuelCount cfg + , explored = Just et + , restSolver = restSolver + , restOCA = restOC + , evOCAlgebra = oc + } + return $ InstEnv + { ieCfg = cfg + , ieSMT = ctx + , ieBEnv = bs fi + , ieAenv = ae fi + , ieCstrs = cs + , ieKnowl = knowledge cfg ctx fi + , ieEvEnv = s0 + } + where + cachedNotStrongerThan refRESTCache oc a b = do + m <- readIORef refRESTCache + case M.lookup (a, b) m of + Nothing -> do + nst <- OC.notStrongerThan oc a b + writeIORef refRESTCache (M.insert (a, b) nst m) + return nst + Just nst -> + return nst + + cachedIsSat refRESTSatCache oc a = do + m <- readIORef refRESTSatCache + case M.lookup a m of + Nothing -> do + sat <- OC.isSat oc a + writeIORef refRESTSatCache (M.insert a sat m) + return sat + Just sat -> + return sat + +---------------------------------------------------------------------------------------------- +-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments +-- +-- The trie is a way to unfold the equalities a minimum number of times. +-- Say you have +-- +-- > 1: [1, 2, 3, 4, 5] => p1 +-- > 2: [1, 2, 3, 6, 7] => p2 +-- +-- Then you build the tree +-- +-- > 1 -> 2 -> 3 -> 4 -> 5 — [Constraint 1] +-- > | -> 6 -> 7 — [Constraint 2] +-- +-- which you use to unfold everything in 1, 2, and 3 once (instead of twice) +-- and with the proper existing environment +-- +mkCTrie :: [(SubcId, SimpC a)] -> CTrie +mkCTrie ics = T.fromList [ (cBinds c, i) | (i, c) <- ics ] + where + cBinds = L.sort . elemsIBindEnv . senv + +---------------------------------------------------------------------------------------------- +-- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE +pleTrie :: CTrie -> InstEnv a -> IO InstRes +pleTrie t env = loopT env' ctx0 diff0 Nothing res0 t + where + env' = env + diff0 = [] + res0 = M.empty + ctx0 = ICtx + { icAssms = mempty + , icCands = mempty + , icEquals = mempty + , icSimpl = mempty + , icSubcId = Nothing + , icANFs = [] + } + +loopT + :: InstEnv a + -> ICtx + -> Diff -- ^ The longest path suffix without forks in reverse order + -> Maybe BindId -- ^ bind id of the branch ancestor of the trie if any. + -- 'Nothing' when this is the top-level trie. + -> InstRes + -> CTrie + -> IO InstRes +loopT env ctx delta i res t = case t of + T.Node [] -> return res + T.Node [b] -> loopB env ctx delta i res b + T.Node bs -> withAssms env ctx delta Nothing $ \env' ctx' -> do + (ctx'', env'', res') <- ple1 env' ctx' i res + foldM (loopB env'' ctx'' [] i) res' bs + +loopB + :: InstEnv a + -> ICtx + -> Diff -- ^ The longest path suffix without forks in reverse order + -> Maybe BindId -- ^ bind id of the branch ancestor of the branch if any. + -- 'Nothing' when this is a branch of the top-level trie. + -> InstRes + -> CBranch + -> IO InstRes +loopB env ctx delta iMb res b = case b of + T.Bind i t -> loopT env ctx (i:delta) (Just i) res t + T.Val cid -> withAssms env ctx delta (Just cid) $ \env' ctx' -> do + progressTick + (\(_, _, r) -> r) <$> ple1 env' ctx' iMb res + +-- | Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@ +-- and the rhs of @cidMb@. +-- +-- Adds to @ctx@ assumptions from @env@ and @delta@. +-- +-- Sets the current constraint id in @ctx@ to @cidMb@. +-- +-- Pushes assumptions from the modified context to the SMT solver, runs @act@, +-- and then pops the assumptions. +-- +withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (InstEnv a -> ICtx -> IO b) -> IO b +withAssms env@InstEnv{..} ctx delta cidMb act = do + let (ctx', env') = updCtx env ctx delta cidMb + let assms = icAssms ctx' + SMT.smtBracket ieSMT "PLE.evaluate" $ do + forM_ assms (SMT.smtAssert ieSMT) + act env' ctx' { icAssms = mempty } + +-- | @ple1@ performs the PLE at a single "node" in the Trie +-- +-- It will generate equalities for all function invocations in the candidates +-- in @ctx@ for which definitions are known. The function definitions are in +-- @ieKnowl@. +ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstEnv a, InstRes) +ple1 ie@InstEnv {..} ctx i res = do + (ctx', env) <- runStateT (evalCandsLoop ieCfg ctx ieSMT ieKnowl) ieEvEnv + let pendings = collectPendingUnfoldings env (icSubcId ctx) + newEqs = pendings ++ S.toList (S.difference (icEquals ctx') (icEquals ctx)) + return (ctx', ie { ieEvEnv = env }, updCtxRes res i newEqs) + where + -- Pending unfoldings (i.e. with undecided guards) are collected only + -- when we reach a leaf in the Trie, and only if the user asked for them. + collectPendingUnfoldings env (Just _) | pleWithUndecidedGuards ieCfg = + M.toList (evPendingUnfoldings env) + collectPendingUnfoldings _ _ = [] + +evalToSMT :: String -> Config -> SMT.Context -> (Expr, Expr) -> Pred +evalToSMT msg cfg ctx (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx [] (EEq e1 e2) + +-- | Generate equalities for all function invocations in the candidates +-- in @ctx@ for which definitions are known. The function definitions are in +-- @ieKnowl@. +-- +-- In pseudocode: +-- +-- > do +-- > for every candidate +-- > discover equalities, +-- > unfold function invocations, +-- > update candidates with the unfolded expressions +-- > send newly discovered equalities to the SMT solver +-- > until no new equalities are discovered +-- > or the environment becomes inconsistent +-- +evalCandsLoop :: Config -> ICtx -> SMT.Context -> Knowledge -> EvalST ICtx +evalCandsLoop cfg ictx0 ctx γ = go ictx0 0 + where + go ictx _ | S.null (icCands ictx) = return ictx + go ictx i = do + inconsistentEnv <- testForInconsistentEnvironment + if inconsistentEnv + then return ictx + else do + liftIO $ SMT.smtAssert ctx (pAndNoDedup (S.toList $ icAssms ictx)) + let ictx' = ictx { icAssms = mempty } + cands = S.toList $ icCands ictx + candss <- mapM (evalOne γ ictx' i) cands + us <- gets evNewEqualities + modify $ \st -> st { evNewEqualities = mempty } + let noCandidateChanged = and (zipWith eqCand candss cands) + unknownEqs = us `S.difference` icEquals ictx + if S.null unknownEqs && noCandidateChanged + then return ictx + else do let eqsSMT = evalToSMT "evalCandsLoop" cfg ctx `S.map` unknownEqs + let ictx'' = ictx' { icEquals = icEquals ictx <> unknownEqs + , icAssms = S.filter (not . isTautoPred) eqsSMT } + go (ictx'' { icCands = S.fromList (concat candss) }) (i + 1) + + testForInconsistentEnvironment = + liftIO $ knPreds γ (knContext γ) (knLams γ) PFalse + + eqCand [e0] e1 = e0 == e1 + eqCand _ _ = False + +---------------------------------------------------------------------------------------------- +-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo +---------------------------------------------------------------------------------------------- + +resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a +resSInfo cfg env fi res = strengthenBinds fi res' + where + res' = M.fromList $ zip is ps'' + ps'' = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' + ps' = defuncAny cfg env ps + (is, ps) = unzip (M.toList res) + +---------------------------------------------------------------------------------------------- +-- | @InstEnv@ has the global information needed to do PLE +---------------------------------------------------------------------------------------------- + +data InstEnv a = InstEnv + { ieCfg :: !Config + , ieSMT :: !SMT.Context + , ieBEnv :: !(BindEnv a) + , ieAenv :: !AxiomEnv + , ieCstrs :: !(CMap (SimpC a)) + , ieKnowl :: !Knowledge + , ieEvEnv :: !EvalEnv + } + +---------------------------------------------------------------------------------------------- +-- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE +---------------------------------------------------------------------------------------------- + +data ICtx = ICtx + { icAssms :: S.HashSet Pred -- ^ Equalities converted to SMT format + , icCands :: S.HashSet Expr -- ^ "Candidates" for unfolding + , icEquals :: EvEqualities -- ^ Accumulated equalities + , icSimpl :: !ConstMap -- ^ Map of expressions to constants + , icSubcId :: Maybe SubcId -- ^ Current subconstraint ID + , icANFs :: [[(Symbol, SortedReft)]] -- Hopefully contain only ANF things + } + +---------------------------------------------------------------------------------------------- +-- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId +---------------------------------------------------------------------------------------------- + +type InstRes = M.HashMap BindId Expr + +---------------------------------------------------------------------------------------------- +-- | @Unfold is the result of running PLE at a single equality; +-- (e, [(e1, e1')...]) is the source @e@ and the (possible empty) +-- list of PLE-generated equalities (e1, e1') ... +---------------------------------------------------------------------------------------------- + +type CTrie = T.Trie SubcId +type CBranch = T.Branch SubcId +type Diff = [BindId] -- ^ in "reverse" order + +equalitiesPred :: [(Expr, Expr)] -> [Expr] +equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ] + +updCtxRes :: InstRes -> Maybe BindId -> [(Expr, Expr)] -> InstRes +updCtxRes res iMb = updRes res iMb . pAndNoDedup . equalitiesPred + + +updRes :: InstRes -> Maybe BindId -> Expr -> InstRes +updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res +updRes res Nothing _ = res + +---------------------------------------------------------------------------------------------- +-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ +-- to the context. +---------------------------------------------------------------------------------------------- + +updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx, InstEnv a) +updCtx env@InstEnv{..} ctx delta cidMb + = ( ctx { icAssms = S.fromList (filter (not . isTautoPred) ctxEqs) + , icCands = S.fromList cands <> icCands ctx + , icSimpl = icSimpl ctx <> econsts + , icSubcId = cidMb + , icANFs = bs : icANFs ctx + } + , env + ) + where + cands = rhs:es + econsts = M.fromList $ findConstants ieKnowl es + ctxEqs = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub + [ c | xr <- bs, c <- conjuncts (expr xr), null (Vis.kvarsExpr c) ] + bs = second unApplySortedReft <$> binds + rhs = unApply eRhs + es = expr <$> bs + eRhs = maybe PTrue crhs subMb + binds = [ (x, y) | i <- delta, let (x, y, _) = lookupBindEnv i ieBEnv] + subMb = getCstr ieCstrs <$> cidMb + + +findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)] +findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)] + where + go su ess = if ess == ess' + then su + else go (su ++ su') ess' + where ess' = subst (mkSubst su') <$> ess + su' = makeSu ess + makeSu exprs = [(x,c) | (EEq (EVar x) c) <- exprs + , isConstant (knDCs γ) c + , EVar x /= c ] + +getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a +getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env + +isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool +isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) + +type EvEqualities = S.HashSet (Expr, Expr) + +-------------------------------------------------------------------------------- +data EvalEnv = EvalEnv + { evEnv :: !SymEnv + -- | Equalities where we couldn't evaluate the guards + , evPendingUnfoldings :: M.HashMap Expr Expr + , evNewEqualities :: EvEqualities -- ^ Equalities discovered during a traversal of + -- an expression + , evSMTCache :: M.HashMap Expr Bool -- ^ Whether an expression is valid or its negation + , evFuel :: FuelCount + + -- REST parameters + , explored :: Maybe (ExploredTerms RuntimeTerm OCType IO) + , restSolver :: Maybe SolverHandle + , restOCA :: RESTOrdering + , evOCAlgebra :: OCAlgebra OCType RuntimeTerm IO + } + +data FuelCount = FC + { fcMap :: M.HashMap Symbol Int + , fcMax :: Maybe Int + } + deriving (Show) + +defFuelCount :: Config -> FuelCount +defFuelCount cfg = FC mempty (fuel cfg) + +type EvalST a = StateT EvalEnv IO a +-------------------------------------------------------------------------------- + +getAutoRws :: Knowledge -> ICtx -> [AutoRewrite] +getAutoRws γ ctx = + Mb.fromMaybe [] $ do + cid <- icSubcId ctx + M.lookup cid $ knAutoRWs γ + +-- | Discover the equalities in an expression. +-- +-- The discovered equalities are in the environment of the monad, +-- and the list of produced expressions contains the result of unfolding +-- definitions. When REST is in effect, more than one expression might +-- be returned because expressions can then be rewritten in more than one +-- way. +evalOne :: Knowledge -> ICtx -> Int -> Expr -> EvalST [Expr] +evalOne γ ctx i e + | i > 0 || null (getAutoRws γ ctx) = (:[]) . fst <$> eval γ ctx NoRW e +evalOne γ ctx _ e = do + env <- get + let oc :: OCAlgebra OCType RuntimeTerm IO + oc = evOCAlgebra env + rp = RP (contramap Rewrite.convert oc) [(e, PLE)] constraints + constraints = OC.top oc + emptyET = ExploredTerms.empty (EF (OC.union oc) (OC.notStrongerThan oc) (OC.refine oc)) ExploreWhenNeeded + es <- evalREST γ ctx rp + modify $ \st -> st { explored = Just emptyET } + return es + +-- The FuncNormal and RWNormal evaluation strategies are used for REST +-- For example, consider the following function: +-- add(x, y) = if x == 0 then y else add(x - 1, y + 1) +-- And a rewrite rule: +-- forall a, b . add(a,b) -> add(b, a) +-- Then the expression add(t, add(2, 1)) would evaluate under NoRW to: +-- if t == 0 then 3 else add(t - 1, 4) +-- However, under FuncNormal, it would evaluate to: add(t, 3) +-- Thus, FuncNormal could engage the rewrite rule add(t, 3) = add(3, t) + + +data EvalType = + NoRW -- Normal PLE + | FuncNormal -- REST: Expand function definitions only when the branch can be decided + | RWNormal -- REST: Fully Expand Defs in the context of rewriting (similar to NoRW) + deriving (Eq) + +-- Indicates whether or not the evaluation has expanded a function statement +-- into a conditional branch. +-- In this case, rewriting should stop +-- It's unclear whether or not rewriting in either branch makes sense, +-- since one branch could be an ill-formed expression. +newtype FinalExpand = FE Bool deriving (Show) + +noExpand :: FinalExpand +noExpand = FE False + +expand :: FinalExpand +expand = FE True + +mapFE :: (Expr -> Expr) -> (Expr, FinalExpand) -> (Expr, FinalExpand) +mapFE f (e, fe) = (f e, fe) + +feVal :: FinalExpand -> Bool +feVal (FE f) = f + +feAny :: [FinalExpand] -> FinalExpand +feAny xs = FE $ any feVal xs + +infixl 9 <|> +(<|>) :: FinalExpand -> FinalExpand -> FinalExpand +(<|>) (FE True) _ = expand +(<|>) _ f = f + + +feSeq :: [(Expr, FinalExpand)] -> ([Expr], FinalExpand) +feSeq xs = (map fst xs, feAny (map snd xs)) + +-- | Unfolds function invocations in expressions. +-- +-- Also reduces if-then-else when the boolean condition or the negation can be +-- proved valid. This is the actual implementation of guard-validation-before-unfolding +-- that is described in publications. +-- +-- Also adds to the monad state all the unfolding equalities that have been +-- discovered as necessary. +-- +eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand) +eval γ ctx et = go + where + go (ELam (x,s) e) = evalELam γ ctx et (x, s) e + go e@EIte{} = evalIte γ ctx et e + go (ECoerc s t e) = mapFE (ECoerc s t) <$> go e + go e@(EApp _ _) = + case splitEAppThroughECst e of + (f, es) | et == RWNormal -> + -- Just evaluate the arguments first, to give rewriting a chance to step in + -- if necessary + do + (es', fe) <- feSeq <$> mapM (eval γ ctx et) es + if es /= es' + then return (eApps f es', fe) + else do + (f', fe) <- eval γ ctx et f + (me', fe') <- evalApp γ ctx f' es et + return (Mb.fromMaybe (eApps f' es') me', fe <|> fe') + (f, es) -> + do + (f':es', fe) <- feSeq <$> mapM (eval γ ctx et) (f:es) + (me', fe') <- evalApp γ ctx f' es' et + return (Mb.fromMaybe (eApps f' es') me', fe <|> fe') + + go (PAtom r e1 e2) = binOp (PAtom r) e1 e2 + go (ENeg e) = do (e', fe) <- eval γ ctx et e + return (ENeg e', fe) + go (EBin o e1 e2) = do (e1', fe1) <- eval γ ctx et e1 + (e2', fe2) <- eval γ ctx et e2 + return (EBin o e1' e2', fe1 <|> fe2) + go (ETApp e t) = mapFE (`ETApp` t) <$> go e + go (ETAbs e s) = mapFE (`ETAbs` s) <$> go e + go (PNot e') = mapFE PNot <$> go e' + go (PImp e1 e2) = binOp PImp e1 e2 + go (PIff e1 e2) = binOp PIff e1 e2 + go (PAnd es) = efAll PAnd (go `traverse` es) + go (POr es) = efAll POr (go `traverse` es) + go e | EVar _ <- dropECst e = do + (me', fe) <- evalApp γ ctx e [] et + return (Mb.fromMaybe e me', fe) + go (ECst e t) = do (e', fe) <- eval γ ctx et e + return (ECst e' t, fe) + go e = return (e, noExpand) + + binOp f e1 e2 = do + (e1', fe1) <- go e1 + (e2', fe2) <- go e2 + return (f e1' e2', fe1 <|> fe2) + + efAll f mes = do + xs <- mes + let (xs', fe) = feSeq xs + return (f xs', fe) + +-- | 'evalELamb' produces equations that preserve the context of a rewrite +-- so equations include any necessary lambda bindings. +evalELam :: Knowledge -> ICtx -> EvalType -> (Symbol, Sort) -> Expr -> EvalST (Expr, FinalExpand) +evalELam γ ctx et (x, s) e = do + oldPendingUnfoldings <- gets evPendingUnfoldings + oldEqs <- gets evNewEqualities + (e', fe) <- eval (γ { knLams = (x, s) : knLams γ }) ctx et e + let e2' = simplify γ ctx e' + elam = ELam (x, s) e + -- Discard the old equalities which miss the lambda binding + modify $ \st -> st + { evPendingUnfoldings = oldPendingUnfoldings + , evNewEqualities = S.insert (elam, ELam (x, s) e2') oldEqs + } + return (elam, fe) + +data RESTParams oc = RP + { oc :: OCAlgebra oc Expr IO + , path :: [(Expr, TermOrigin)] + , c :: oc + } + +-- Reverse the ANF transformation +deANF :: ICtx -> Expr -> Expr +deANF ctx = inlineInExpr (`HashMap.Lazy.lookup` undoANF id bindEnv) + where + bindEnv = HashMap.Lazy.unions $ map HashMap.Lazy.fromList $ icANFs ctx + +-- | +-- Adds to the monad state all the subexpressions that have been rewritten +-- as pairs @(original_subexpression, rewritten_subexpression)@. +-- +-- Also folds constants. +-- +-- The main difference with 'eval' is that 'evalREST' takes into account +-- autorewrites. +-- +evalREST :: Knowledge -> ICtx -> RESTParams OCType -> EvalST [Expr] +evalREST γ ctx rp = do + env <- get + cacheRef <- liftIO $ newIORef $ evSMTCache env + evalRESTWithCache cacheRef γ ctx [] rp + +evalRESTWithCache + :: IORef (M.HashMap Expr Bool) -> Knowledge -> ICtx -> [Expr] -> RESTParams OCType -> EvalST [Expr] +evalRESTWithCache cacheRef _ ctx acc rp + | pathExprs <- map fst (mytracepp "EVAL1: path" $ path rp) + , e <- last pathExprs + , Just v <- M.lookup e (icSimpl ctx) + = do + smtCache <- liftIO $ readIORef cacheRef + when (v /= e) $ modify (\st -> st + { evNewEqualities = S.insert (e, v) (evNewEqualities st) + , evSMTCache = smtCache + }) + return (v : acc) + +evalRESTWithCache cacheRef γ ctx acc rp = + do + Just exploredTerms <- gets explored + se <- liftIO (shouldExploreTerm exploredTerms e) + if se then do + possibleRWs <- getRWs + rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed) possibleRWs + oldEqualities <- gets evNewEqualities + modify $ \st -> st { evNewEqualities = mempty } + + -- liftIO $ putStrLn $ (show $ length possibleRWs) ++ " rewrites allowed at path length " ++ (show $ (map snd $ path rp)) + (e', FE fe) <- do + r@(ec, _) <- eval γ ctx FuncNormal e + if ec /= e + then return r + else eval γ ctx RWNormal e + + let evalIsNewExpr = e' `L.notElem` pathExprs + let exprsToAdd = [e' | evalIsNewExpr] ++ map (\(_, e, _) -> e) rws + acc' = exprsToAdd ++ acc + eqnToAdd = [ (e1, simplify γ ctx e2) | ((e1, e2), _, _) <- rws ] + + newEqualities <- gets evNewEqualities + smtCache <- liftIO $ readIORef cacheRef + modify (\st -> + st { evNewEqualities = foldr S.insert (S.union newEqualities oldEqualities) eqnToAdd + , evSMTCache = smtCache + , explored = Just $ ExploredTerms.insert + (Rewrite.convert e) + (c rp) + (S.insert (Rewrite.convert e') $ S.fromList (map (Rewrite.convert . (\(_, e, _) -> e)) possibleRWs)) + (Mb.fromJust $ explored st) + }) + + acc'' <- if evalIsNewExpr + then if fe && any isRW (path rp) + then (:[]) . fst <$> eval γ (addConst (e, e')) NoRW e' + else evalRESTWithCache cacheRef γ (addConst (e, e')) acc' (rpEval newEqualities e') + else return acc' + + foldM (\r rw -> evalRESTWithCache cacheRef γ ctx r (rpRW rw)) acc'' rws + else + return acc + where + shouldExploreTerm exploredTerms e | Vis.isConc e = + case rwTerminationOpts rwArgs of + RWTerminationCheckDisabled -> + return $ not $ ExploredTerms.visited (Rewrite.convert e) exploredTerms + RWTerminationCheckEnabled -> + ExploredTerms.shouldExplore (Rewrite.convert e) (c rp) exploredTerms + shouldExploreTerm _ _ = return False + + allowed (_, rwE, _) | rwE `elem` pathExprs = return False + allowed (_, _, c) = termCheck c + termCheck c = Rewrite.passesTerminationCheck (oc rp) rwArgs c + + notVisitedFirst exploredTerms rws = + let + (v, nv) = L.partition (\(_, e, _) -> ExploredTerms.visited (Rewrite.convert e) exploredTerms) rws + in + nv ++ v + + rpEval newEqualities e' = + let + c' = + if any isRW (path rp) + then foldr (\(e1, e2) ctrs -> refine (oc rp) ctrs e1 e2) (c rp) (S.toList newEqualities) + else c rp + + in + rp{path = path rp ++ [(e', PLE)], c = c'} + + isRW (_, r) = r == RW + + rpRW (_, e', c') = rp{path = path rp ++ [(e', RW)], c = c' } + + pathExprs = map fst (mytracepp "EVAL2: path" $ path rp) + e = last pathExprs + autorws = getAutoRws γ ctx + + rwArgs = RWArgs (isValid cacheRef γ) $ knRWTerminationOpts γ + + getRWs = + do + -- Optimization: If we got here via rewriting, then the current constraints + -- are satisfiable; otherwise double-check that rewriting is still allowed + ok <- + if isRW $ last (path rp) + then return True + else liftIO $ termCheck (c rp) + if ok + then + do + let e' = deANF ctx e + let getRW e ar = Rewrite.getRewrite (oc rp) rwArgs (c rp) e ar + let getRWs' s = Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRW s) autorws + concat <$> mapM getRWs' (subExprs e') + else return [] + + addConst (e,e') = if isConstant (knDCs γ) e' + then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx + +-- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites +-- and equations +evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Maybe Expr, FinalExpand) +evalApp γ ctx e0 es et + | EVar f <- dropECst e0 + , Just eq <- Map.lookup f (knAms γ) + , length (eqArgs eq) <= length es + = do + env <- gets (seSort . evEnv) + okFuel <- checkFuel f + if okFuel && et /= FuncNormal + then do + let (es1,es2) = splitAt (length (eqArgs eq)) es + newE = substEq env eq es1 + (e', fe) <- evalIte γ ctx et newE -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter + let mPLEUnfold = startsWithPLEUnfold e' + e2' = Mb.fromMaybe e' mPLEUnfold + e3' = simplify γ ctx (eApps e2' es2) -- reduces a bit the equations + undecidedGuards = case e' of + EIte{} -> True + _ -> False + + if not undecidedGuards || Mb.isJust mPLEUnfold + then do + useFuel f + modify $ \st -> + st + { evNewEqualities = S.insert (eApps e0 es, e3') (evNewEqualities st) + , evPendingUnfoldings = M.delete (eApps e0 es) (evPendingUnfoldings st) + } + return (Just e2', fe) + else do + modify $ \st -> + st { + evPendingUnfoldings = M.insert (eApps e0 es) e3' (evPendingUnfoldings st) + } + -- Don't unfold the expression if there is an if-then-else + -- guarding it, just to preserve the size of further + -- rewrites. + return (Nothing, noExpand) + else return (Nothing, noExpand) + where + -- At the time of writing, any function application wrapping an + -- if-statement would have the effect of unfolding the invocation. + -- However, using pleUnfold still has the advantage of not generating + -- extra equations to unfold pleUnfold itself. Using pleUnfold also + -- makes the intention of the user rather explicit. + startsWithPLEUnfold e + | (ef, [arg]) <- splitEAppThroughECst e + , EVar f <- dropECst ef + , f == "Language.Haskell.Liquid.ProofCombinators.pleUnfold" + = Just arg + | otherwise = Nothing + +evalApp γ ctx e0 args@(e:es) _ + | EVar f <- dropECst e0 + , (d, as) <- splitEAppThroughECst e + , EVar dc <- dropECst d + , Just rws <- Map.lookup dc (knSims γ) + -- User data measures aren't sent to the SMT solver because + -- it knows already about selectors and constructor tests. + , Just (rw, isUserDataSMeasure) <- L.find (\(rw, _) -> smName rw == f) rws + , length as == length (smArgs rw) + = do + let newE = eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es + when (isUserDataSMeasure == NoUserDataSMeasure) $ + modify $ \st -> + st { evNewEqualities = + S.insert (eApps e0 args, simplify γ ctx newE) (evNewEqualities st) + } + return (Just newE, noExpand) + +evalApp γ ctx e0 es _et + | eqs@(_:_) <- noUserDataMeasureEqs γ (eApps e0 es) + = do + let eqs' = map (second $ simplify γ ctx) eqs + modify $ \st -> + st { evNewEqualities = foldr S.insert (evNewEqualities st) eqs' } + return (Nothing, noExpand) + +evalApp _ _ _e _es _ + = return (Nothing, noExpand) + +-- | Evaluates if-then-else statements until they can't be evaluated anymore +-- or some other expression is found. +evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand) +evalIte γ ctx et (EIte i e1 e2) = do + (b, _) <- eval γ ctx et i + b' <- mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValidCached γ b + case b' of + Just True -> evalIte γ ctx et e1 + Just False -> evalIte γ ctx et e2 + _ -> return (EIte b e1 e2, expand) +evalIte _ _ _ e' = return (e', noExpand) + +-- | Creates equations that explain how to rewrite a given constructor +-- application with all measures that aren't user data measures +noUserDataMeasureEqs :: Knowledge -> Expr -> [(Expr,Expr)] +noUserDataMeasureEqs γ e = + [ (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw)) + | (ef, es) <- [splitEAppThroughECst e] + , EVar f <- [dropECst ef] + , Just rws <- [Map.lookup f (knSims γ)] + , (rw, NoUserDataSMeasure) <- rws + , length es == length (smArgs rw) + ] + +-------------------------------------------------------------------------------- +-- | 'substEq' unfolds or instantiates an equation at a particular list of +-- argument values. We must also substitute the sort-variables that appear +-- as coercions. See tests/proof/ple1.fq +-------------------------------------------------------------------------------- +substEq :: SEnv Sort -> Equation -> [Expr] -> Expr +substEq env eq es = subst su (substEqCoerce env eq es) + where su = mkSubst $ zip (eqArgNames eq) es + +substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr +substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq + where + ts = snd <$> eqArgs eq + sp = panicSpan "mkCoSub" + eTs = sortExpr sp env <$> es + coSub = mkCoSub env eTs ts + +-- | @mkCoSub senv eTs xTs = su@ creates a substitution @su@ such that +-- @subst su xTs == eTs@. +-- +-- The variables in the domain of the substitution are those that appear +-- as @FObj symbol@ in @xTs@. +mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub +mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] + where + unite ts = Mb.fromMaybe (uError ts) (unifyTo1 senv ts) + senv = mkSearchEnv env + uError ts = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) + xys = Misc.sortNub $ concat $ zipWith matchSorts xTs eTs + +matchSorts :: Sort -> Sort -> [(Symbol, Sort)] +matchSorts s1 s2 = go s1 s2 + where + go (FObj x) {-FObj-} y = [(x, y)] + go (FAbs _ t1) (FAbs _ t2) = go t1 t2 + go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2 + go (FApp s1 t1) (FApp s2 t2) = go s1 s2 ++ go t1 t2 + go _ _ = [] + +-------------------------------------------------------------------------------- + +eqArgNames :: Equation -> [Symbol] +eqArgNames = map fst . eqArgs + +isValidCached :: Knowledge -> Expr -> EvalST (Maybe Bool) +isValidCached γ e = do + env <- get + case M.lookup e (evSMTCache env) of + Nothing -> do + let isFreeInE (s, _) = not (S.member s (exprSymbolsSet e)) + b <- liftIO $ knPreds γ (knContext γ) (knLams γ) e + if b + then do + when (all isFreeInE (knLams γ)) $ + put (env { evSMTCache = M.insert e True (evSMTCache env) }) + return (Just True) + else do + b2 <- liftIO $ knPreds γ (knContext γ) (knLams γ) (PNot e) + if b2 + then do + when (all isFreeInE (knLams γ)) $ + put (env { evSMTCache = M.insert e False (evSMTCache env) }) + return (Just False) + else + return Nothing + + mb -> return mb + +-------------------------------------------------------------------------------- +-- | Knowledge (SMT Interaction) +-------------------------------------------------------------------------------- +data Knowledge = KN + { -- | Rewrites rules came from match definitions + -- + -- They are grouped by the data constructor that they unfold, and are + -- augmented with an attribute that say whether they originate from a + -- user data declaration. + knSims :: Map Symbol [(Rewrite, IsUserDataSMeasure)] + , knAms :: Map Symbol Equation -- ^ All function definitions + , knContext :: SMT.Context + , knPreds :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool + , knLams :: ![(Symbol, Sort)] + , knSummary :: ![(Symbol, Int)] -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity + , knDCs :: !(S.HashSet Symbol) -- ^ data constructors drawn from Rewrite + , knDataCtors :: !(M.HashMap Symbol DataCtor) -- ^ data constructors by name + , knSels :: !SelectorMap + , knConsts :: !ConstDCMap + , knAutoRWs :: M.HashMap SubcId [AutoRewrite] + , knRWTerminationOpts :: RWTerminationOpts + } + +-- | A type to express whether SMeasures originate from data definitions. +-- That is whether they are constructor tests, selectors, or something else. +data IsUserDataSMeasure = NoUserDataSMeasure | UserDataSMeasure + deriving (Eq, Show) + +isValid :: IORef (M.HashMap Expr Bool) -> Knowledge -> Expr -> IO Bool +isValid cacheRef γ e = do + smtCache <- readIORef cacheRef + case M.lookup e smtCache of + Nothing -> do + b <- knPreds γ (knContext γ) (knLams γ) e + when b $ + writeIORef cacheRef (M.insert e True smtCache) + return b + mb -> return (mb == Just True) + +knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge +knowledge cfg ctx si = KN + { knSims = Map.fromListWith (++) $ + [ (smDC rw, [(rw, NoUserDataSMeasure)]) | rw <- sims ] ++ + [ (smDC rw, [(rw, UserDataSMeasure)]) | rw <- dataSims ] + , knAms = Map.fromList [(eqName eq, eq) | eq <- aenvEqs aenv] + , knContext = ctx + , knPreds = askSMT cfg + , knLams = [] + , knSummary = ((\s -> (smName s, 1)) <$> sims) + ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv) + ++ rwSyms + , knDCs = S.fromList (smDC <$> sims) + , knDataCtors = M.fromList [ (val (dcName dc), dc) | dd <- ddecls si, dc <- ddCtors dd ] + , knSels = Mb.mapMaybe makeSel sims + , knConsts = Mb.mapMaybe makeCons sims + , knAutoRWs = aenvAutoRW aenv + , knRWTerminationOpts = + if rwTerminationCheck cfg + then RWTerminationCheckEnabled + else RWTerminationCheckDisabled + } + where + (simDCTests, sims0) = + partitionUserDataConstructorTests (ddecls si) $ aenvSimpl aenv + (simDCSelectors, sims) = + partitionUserDataConstructorSelectors (ddecls si) sims0 + dataSims = simDCTests ++ simDCSelectors + aenv = ae si + + inRewrites :: Symbol -> Bool + inRewrites e = + let + syms = Mb.mapMaybe (lhsHead . arLHS) (concat $ M.elems $ aenvAutoRW aenv) + in + e `L.elem` syms + + lhsHead :: Expr -> Maybe Symbol + lhsHead e | (ef, _) <- splitEAppThroughECst e, EVar f <- dropECst ef = Just f + lhsHead _ = Nothing + + + rwSyms = filter (inRewrites . fst) $ map toSum (toListSEnv (gLits si)) + where + toSum (sym, sort) = (sym, getArity sort) + + getArity (FFunc _ rhs) = 1 + getArity rhs + getArity _ = 0 + + + + makeCons rw + | null (syms $ smBody rw) + = Just (smName rw, (smDC rw, smBody rw)) + | otherwise + = Nothing + + makeSel rw + | EVar x <- smBody rw + = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw) + | otherwise + = Nothing + +-- | Partitions the input rewrites into constructor tests and others. +-- +-- We don't need to deal in PLE with data constructor tests. That is, +-- functions of the form @isCons :: List a -> Bool@ or @isNil :: List a -> Bool@ +-- when @List a@ is defined by the user. +-- +-- The SMT solver knows about these functions when datatypes are declared to it, +-- so PLE doesn't need to unfold them. +-- +-- Non-user defined datatypes like @[a]@ still need to have tests unfolded +-- because they are not declared as datatypes to the SMT solver. +-- +-- Also, REST could need this functions unfolded since otherwise it may not +-- discover possible rewrites. +-- +partitionUserDataConstructorTests :: [DataDecl] -> [Rewrite] -> ([Rewrite], [Rewrite]) +partitionUserDataConstructorTests dds rws = L.partition isDataConstructorTest rws + where + isDataConstructorTest sm = isTestSymbol (smName sm) && S.member (smDC sm) userDefinedDcs + userDefinedDcs = + S.fromList [ symbol (dcName dc) | dd <- dds, dc <- ddCtors dd ] + +-- | Like 'partitionUserDataConstructorTests' but for selectors. +partitionUserDataConstructorSelectors :: [DataDecl] -> [Rewrite] -> ([Rewrite], [Rewrite]) +partitionUserDataConstructorSelectors dds rws = L.partition isSelector rws + where + isSelector sm = S.member (smName sm) userDefinedDcFieldsSelectors + userDefinedDcFieldsSelectors = + S.fromList [ symbol dcf | dd <- dds, dc <- ddCtors dd, dcf <- dcFields dc ] + + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +withCtx :: Config -> FilePath -> SymEnv -> (SMT.Context -> IO a) -> IO a +withCtx cfg file env k = do + ctx <- SMT.makeContextWithSEnv cfg file env + _ <- SMT.smtPush ctx + res <- k ctx + _ <- SMT.cleanupContext ctx + return res + + +-- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi, +-- i.e., sel_i selects the ith value for the data constructor D +type SelectorMap = [(Symbol, (Symbol, Int))] +type ConstDCMap = [(Symbol, (Symbol, Expr))] + +-- ValueMap maps expressions to constants (including data constructors) +type ConstMap = M.HashMap Expr Expr +type LDataCon = Symbol -- Data Constructors + +isConstant :: S.HashSet LDataCon -> Expr -> Bool +isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs) + +simplify :: Knowledge -> ICtx -> Expr -> Expr +simplify γ ictx e = mytracepp ("simplification of " ++ showpp e) $ fix (Vis.mapExprOnExpr tx) e + where + fix f e = if e == e' then e else fix f e' where e' = f e + tx e + | Just e' <- M.lookup e (icSimpl ictx) + = e' + + tx (PAtom rel e1 e2) = applyBooleanFolding rel e1 e2 + tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2 + tx (ENeg e) = applyConstantFolding Minus (ECon (I 0)) e + tx (EApp e1 e2) + | isSetPred e1 = applySetFolding e1 e2 + + tx (EApp ef a) + | EVar f <- dropECst ef + , Just (dc, c) <- L.lookup f (knConsts γ) + , (ed, _) <- splitEAppThroughECst a + , EVar dc' <- dropECst ed + , dc == dc' + = c + tx (EIte b e1 e2) + | isTautoPred b = e1 + | isContraPred b = e2 + tx (ECoerc s t e) + | s == t = e + tx (EApp ef a) + | EVar f <- dropECst ef + , Just (dc, i) <- L.lookup f (knSels γ) + , (ed, es) <- splitEAppThroughECst a + , EVar dc' <- dropECst ed + , dc == dc' + = es!!i + tx e = e + + +------------------------------------------------------------------------------- +-- | Normalization of Equation: make their arguments unique ------------------- +------------------------------------------------------------------------------- + +class Normalizable a where + normalize :: a -> a + +instance Normalizable (GInfo c a) where + normalize si = si {ae = normalize $ ae si} + +instance Normalizable AxiomEnv where + normalize aenv = aenv { aenvEqs = mytracepp "aenvEqs" (normalize <$> aenvEqs aenv) + , aenvSimpl = mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) } + +instance Normalizable Rewrite where + normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw } + where + su = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs' + xs = smArgs rw + xs' = zipWith mkSymbol xs [0 :: Integer ..] + mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i + + +instance Normalizable Equation where + normalize eq = eq {eqArgs = zip xs' ss, eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq } + where + su = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs' + (xs,ss) = unzip (eqArgs eq) + xs' = zipWith mkSymbol xs [0 :: Integer ..] + mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i + +-- | Normalize the given named expression if it is recursive. +normalizeBody :: Symbol -> Expr -> Expr +normalizeBody f e | f `elem` syms e = go e + where + -- @go@ performs this simplification: + -- (c => e1) /\ ((not c) => e2) --> if c then e1 else e2 + -- and then recurses into e2. + -- + -- The expressions originate from Haskell's reflect annotations, so we know + -- that e1 is a conjunction of data constructor checkers and we do not need + -- to recurse into e1. + go (PAnd [PImp c e1, PImp (PNot c') e2]) | c == c' = EIte c e1 (go e2) + go e = e +normalizeBody _ e = e -- The expression is not recursive, return it unchanged. + +-- -- TODO:FUEL Config +-- maxFuel :: Int +-- maxFuel = 11 + +-- | Increment the fuel count of the given symbol in the current evaluation +-- environment. +useFuel :: Symbol -> EvalST () +useFuel f = do + modify (\st -> st { evFuel = useFuelCount f (evFuel st) }) + +-- | Increment the fuel count. +useFuelCount :: Symbol -> FuelCount -> FuelCount +useFuelCount f fc = fc { fcMap = M.insert f (k + 1) m } + where + k = M.lookupDefault 0 f m + m = fcMap fc + +-- | Returns False if there is a fuel count in the evaluation environment and +-- the fuel count exceeds the maximum. Returns True otherwise. +checkFuel :: Symbol -> EvalST Bool +checkFuel f = do fc <- gets evFuel case (M.lookup f (fcMap fc), fcMax fc) of (Just fk, Just n) -> pure (fk <= n) diff --git a/src/Language/Fixpoint/Solver/Prettify.hs b/src/Language/Fixpoint/Solver/Prettify.hs --- a/src/Language/Fixpoint/Solver/Prettify.hs +++ b/src/Language/Fixpoint/Solver/Prettify.hs @@ -1,10 +1,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | Functions to make environments easier to read module Language.Fixpoint.Solver.Prettify (savePrettifiedQuery) where @@ -23,7 +23,7 @@ , inlineInSortedReft , mergeDuplicatedBindings , simplifyBooleanRefts - , undoANF + , undoANFAndVV ) import Language.Fixpoint.Types.Config (Config, queryFile) import Language.Fixpoint.Types.Constraints @@ -41,9 +41,11 @@ import Language.Fixpoint.Types.PrettyPrint import Language.Fixpoint.Types.Refinements ( Expr(..) + , pattern PFalse , Reft , SortedReft(..) , conjuncts + , expr , reft , reftBind , reftPred @@ -69,31 +71,35 @@ prettyConstraints :: Fixpoint a => FInfo a -> Doc prettyConstraints fi = vcat $ - map (prettyConstraint (bs fi)) $ - map snd $ - sortOn fst $ - HashMap.toList (cm fi) + map + (prettyConstraint (bs fi) . snd) + (sortOn fst $ HashMap.toList (cm fi)) prettyConstraint :: Fixpoint a - => BindEnv + => BindEnv a -> SubC a -> Doc prettyConstraint bindEnv c = - let env = [ (s, ([bId], sr)) + let env = [ (s, ([(bId, a)], sr)) | bId <- elemsIBindEnv $ senv c - , let (s, sr) = lookupBindEnv bId bindEnv + , let (s, sr, a) = lookupBindEnv bId bindEnv ] mergedEnv = mergeDuplicatedBindings env - undoANFEnv = HashMap.union (undoANF mergedEnv) mergedEnv - boolSimplEnv = HashMap.union (simplifyBooleanRefts undoANFEnv) undoANFEnv + undoANFEnv = undoANFAndVV mergedEnv + boolSimplEnvDiff = simplifyBooleanRefts undoANFEnv + boolSimplEnv = HashMap.map snd $ HashMap.union boolSimplEnvDiff undoANFEnv - simplifiedLhs = inlineInSortedReft boolSimplEnv (slhs c) - simplifiedRhs = inlineInSortedReft boolSimplEnv (srhs c) + simplifiedLhs = simplify $ inlineInSortedReft (`HashMap.lookup` boolSimplEnv) (slhs c) + simplifiedRhs = simplify $ inlineInSortedReft (`HashMap.lookup` boolSimplEnv) (srhs c) prunedEnv = - dropLikelyIrrelevantBindings (constraintSymbols simplifiedLhs simplifiedRhs) $ - HashMap.map snd boolSimplEnv + if expr simplifiedRhs /= PFalse then + dropLikelyIrrelevantBindings + (constraintSymbols simplifiedLhs simplifiedRhs) + boolSimplEnv + else + boolSimplEnv (renamedEnv, c') = shortenVarNames prunedEnv c { slhs = simplifiedLhs, srhs = simplifiedRhs } prettyEnv = @@ -181,16 +187,16 @@ renameSortedReft :: HashMap Symbol Symbol -> SortedReft -> SortedReft renameSortedReft symMap (RR t r) = - let sortSubst = FObj . (at symMap) + let sortSubst = FObj . at symMap in RR (substSort sortSubst t) (renameReft symMap r) renameReft :: HashMap Symbol Symbol -> Reft -> Reft renameReft symMap r = let m = HashMap.insert (reftBind r) (prefixOfSym $ reftBind r) symMap - sortSubst = FObj . (at symMap) + sortSubst = FObj . at symMap in reft (at m (reftBind r)) $ substSortInExpr sortSubst $ - (substf (EVar . (at m)) $ reftPred r) + substf (EVar . at m) (reftPred r) at :: HashMap Symbol Symbol -> Symbol -> Symbol at m k = fromMaybe k $ HashMap.lookup k m @@ -220,7 +226,7 @@ -- -- > forall ss. -- > Set.fromList ss == Set.fromList $ concat [ xs | m <- elems (toPrefixSuffixMap ss), xs <- elems m ] --- +-- -- > forall ss. -- > and [ all (pfx `isPrefixOfSym`) xs && all (sfx `isSuffixOfSym`) xs -- > | (pfx, m) <- toList (toPrefixSuffixMap ss) @@ -251,7 +257,7 @@ renameWithAppendages pfx (sfx, ss) = zip ss $ case ss of [_s] -> [pfx `suffixIfNotNull` sfx] - ss -> zipWith (rename pfx sfx) [1..] ss + ss -> zipWith (rename pfx sfx) [1 :: Integer ..] ss rename pfx sfx i _s = pfx `suffixIfNotNull` sfx `suffixSymbol` symbol (show i) diff --git a/src/Language/Fixpoint/Solver/Rewrite.hs b/src/Language/Fixpoint/Solver/Rewrite.hs --- a/src/Language/Fixpoint/Solver/Rewrite.hs +++ b/src/Language/Fixpoint/Solver/Rewrite.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver.Rewrite ( getRewrite - -- , getRewrite' , subExprs , unify , ordConstraints @@ -15,22 +17,32 @@ , RWTerminationOpts(..) , SubExpr , TermOrigin(..) + , OCType + , RESTOrdering(..) ) where -import Control.Monad.State +import Control.Monad.State (guard) import Control.Monad.Trans.Maybe +import Data.Hashable import qualified Data.HashMap.Strict as M import qualified Data.List as L import qualified Data.Text as TX import GHC.IO.Handle.Types (Handle) +import GHC.Generics import Text.PrettyPrint (text) +import Language.Fixpoint.Types.Config (RESTOrdering(..)) import Language.Fixpoint.Types hiding (simplify) import Language.REST -import Language.REST.AbstractOC -import qualified Language.REST.RuntimeTerm as RT +import Language.REST.KBO (kbo) +import Language.REST.LPO (lpo) +import Language.REST.OCAlgebra as OC +import Language.REST.OCToAbstract (lift) import Language.REST.Op -import Language.REST.OrderingConstraints.ADT (ConstraintsADT) +import Language.REST.SMT (SMTExpr) +import Language.REST.WQOConstraints.ADT (ConstraintsADT, adtOC) +import qualified Language.REST.RuntimeTerm as RT +-- | @(e, f)@ asserts that @e@ is a subexpression of @f e@ type SubExpr = (Expr, Expr -> Expr) data TermOrigin = PLE | RW deriving (Show, Eq) @@ -48,13 +60,40 @@ , rwTerminationOpts :: RWTerminationOpts } -ordConstraints :: (Handle, Handle) -> AbstractOC (ConstraintsADT Op) Expr IO -ordConstraints solver = contramap convert (adtRPO solver) +-- Monomorphize ordering constraints so we don't litter PLE with type variables +-- Also helps since GHC doesn't support impredicate polymorphism (yet) +data OCType = + RPO (ConstraintsADT Op) + | LPO (ConstraintsADT Op) + | KBO (SMTExpr Bool) + | Fuel Int + deriving (Eq, Show, Generic, Hashable) +ordConstraints :: RESTOrdering -> (Handle, Handle) -> OCAlgebra OCType RT.RuntimeTerm IO +ordConstraints RESTRPO solver = bimapConstraints RPO asRPO (adtRPO solver) + where + asRPO (RPO t) = t + asRPO _ = undefined +ordConstraints RESTKBO solver = bimapConstraints KBO asKBO (kbo solver) + where + asKBO (KBO t) = t + asKBO _ = undefined + +ordConstraints RESTLPO solver = bimapConstraints LPO asLPO (lift (adtOC solver) lpo) + where + asLPO (LPO t) = t + asLPO _ = undefined + +ordConstraints (RESTFuel n) _ = bimapConstraints Fuel asFuel $ fuelOC n + where + asFuel (Fuel n) = n + asFuel _ = undefined + + convert :: Expr -> RT.RuntimeTerm convert (EIte i t e) = RT.App "$ite" $ map convert [i,t,e] -convert e@(EApp{}) | (EVar fName, terms) <- splitEApp e +convert e@EApp{} | (f, terms) <- splitEAppThroughECst e, EVar fName <- dropECst f = RT.App (Op (symbolText fName)) $ map convert terms convert (EVar s) = RT.App (Op (symbolText s)) [] convert (PNot e) = RT.App "$not" [ convert e ] @@ -65,35 +104,46 @@ convert (ECon c) = RT.App (Op $ "$econ" `TX.append` (TX.pack . show) c) [] convert (ESym (SL tx)) = RT.App (Op tx) [] convert (ECst t _) = convert t +convert (PIff e0 e1) = convert (PAtom Eq e0 e1) +convert (PImp e0 e1) = convert (POr [PNot e0, e1]) convert e = error (show e) -passesTerminationCheck :: AbstractOC oc a IO -> RewriteArgs -> oc -> IO Bool +passesTerminationCheck :: OCAlgebra oc a IO -> RewriteArgs -> oc -> IO Bool passesTerminationCheck aoc rwArgs c = case rwTerminationOpts rwArgs of RWTerminationCheckEnabled -> isSat aoc c RWTerminationCheckDisabled -> return True +-- | Yields the result of rewriting an expression with an autorewrite equation. +-- +-- Yields nothing if: +-- +-- * The result of the rewrite is identical to the original expression +-- * Any of the arguments of the autorewrite has a refinement type which is +-- not satisfied in the current context. +-- getRewrite :: - AbstractOC oc Expr IO + OCAlgebra oc Expr IO -> RewriteArgs -> oc -> SubExpr -> AutoRewrite - -> MaybeT IO (Expr, oc) + -> MaybeT IO ((Expr, Expr), Expr, oc) getRewrite aoc rwArgs c (subE, toE) (AutoRewrite args lhs rhs) = do su <- MaybeT $ return $ unify freeVars lhs subE let subE' = subst su rhs guard $ subE /= subE' let expr' = toE subE' + eqn = (subst su lhs, subE') mapM_ (checkSubst su) exprs return $ case rwTerminationOpts rwArgs of RWTerminationCheckEnabled -> let c' = refine aoc c subE subE' in - (expr', c') - RWTerminationCheckDisabled -> (expr', c) + (eqn, expr', c') + RWTerminationCheckDisabled -> (eqn, expr', c) where check :: Expr -> MaybeT IO () check e = do @@ -105,7 +155,7 @@ checkSubst su (s, e) = do - let su' = (catSubst su $ mkSubst [("VV", subst su (EVar s))]) + let su' = catSubst su $ mkSubst [("VV", subst su (EVar s))] -- liftIO $ printf "Substitute %s in %s\n" (show su') (show e) check $ subst (catSubst su su') e @@ -127,7 +177,7 @@ lhs'' = map (\(e, f) -> (e, \e' -> EBin op (f e') rhs)) lhs' rhs'' :: [SubExpr] rhs'' = map (\(e, f) -> (e, \e' -> EBin op lhs (f e'))) rhs' - + subExprs' (PImp lhs rhs) = lhs'' ++ rhs'' where lhs' = subExprs lhs @@ -136,7 +186,16 @@ lhs'' = map (\(e, f) -> (e, \e' -> PImp (f e') rhs)) lhs' rhs'' :: [SubExpr] rhs'' = map (\(e, f) -> (e, \e' -> PImp lhs (f e'))) rhs' - + +subExprs' (PIff lhs rhs) = lhs'' ++ rhs'' + where + lhs' = subExprs lhs + rhs' = subExprs rhs + lhs'' :: [SubExpr] + lhs'' = map (\(e, f) -> (e, \e' -> PIff (f e') rhs)) lhs' + rhs'' :: [SubExpr] + rhs'' = map (\(e, f) -> (e, \e' -> PIff lhs (f e'))) rhs' + subExprs' (PAtom op lhs rhs) = lhs'' ++ rhs'' where lhs' = subExprs lhs @@ -146,10 +205,10 @@ rhs'' :: [SubExpr] rhs'' = map (\(e, f) -> (e, \e' -> PAtom op lhs (f e'))) rhs' -subExprs' e@(EApp{}) = - if (f == EVar "Language.Haskell.Liquid.ProofCombinators.===" || - f == EVar "Language.Haskell.Liquid.ProofCombinators.==." || - f == EVar "Language.Haskell.Liquid.ProofCombinators.?") +subExprs' e@EApp{} = + if f == EVar "Language.Haskell.Liquid.ProofCombinators.===" || + f == EVar "Language.Haskell.Liquid.ProofCombinators.==." || + f == EVar "Language.Haskell.Liquid.ProofCombinators.?" then [] else concatMap replace indexedArgs where @@ -157,10 +216,31 @@ indexedArgs = zip [0..] es replace (i, arg) = do (subArg, toArg) <- subExprs arg - return (subArg, \subArg' -> eApps f $ (take i es) ++ (toArg subArg'):(drop (i+1) es)) + return (subArg, \subArg' -> eApps f $ take i es ++ toArg subArg' : drop (i+1) es) +subExprs' (ECst e t) = + [ (e', \subE -> ECst (toE subE) t) | (e', toE) <- subExprs' e ] + +subExprs' (PAnd es) = [ (e, PAnd . f) | (e, f) <- subs es ] + +subExprs' (POr es) = [ (e, POr . f) | (e, f) <- subs es ] + subExprs' _ = [] +-- | Computes the subexpressions of a list of expressions. +-- Each subexpression comes with a function that rebuilds the +-- context in which the subexpression occurs. +-- +-- > and [ es == f e | (e, f) <- subs es ] +-- +subs :: [Expr] -> [(Expr, Expr -> [Expr])] +subs [] = [] +subs [x] = [ (s, \e -> [f e]) | (s, f) <- subExprs x ] +subs (x:xs) = [ (s, \e -> f e : xs) | (s, f) <- subExprs x ] + ++ + [ (s, \e -> x : f e) | (s, f) <- subs xs ] + + unifyAll :: [Symbol] -> [Expr] -> [Expr] -> Maybe Subst unifyAll _ [] [] = Just (Su M.empty) unifyAll freeVars (template:xs) (seen:ys) = @@ -172,50 +252,60 @@ return $ Su (M.union s1 s2) unifyAll _ _ _ = undefined +-- | @unify vs template e = Just su@ yields a substitution @su@ +-- such that subst su template == e +-- +-- Moreover, @su@ is constraint to only substitute variables in @vs@. +-- +-- Yields @Nothing@ if no substitution exists. +-- unify :: [Symbol] -> Expr -> Expr -> Maybe Subst unify _ template seenExpr | template == seenExpr = Just (Su M.empty) -unify freeVars template seenExpr = case (template, seenExpr) of +unify freeVars template seenExpr = case (dropECst template, seenExpr) of + -- preserve seen casts if possible (EVar rwVar, _) | rwVar `elem` freeVars -> return $ Su (M.singleton rwVar seenExpr) - (EVar lhs, EVar rhs) | removeModName lhs == removeModName rhs -> - Just (Su M.empty) - where - removeModName ts = go "" (symbolString ts) where - go buf [] = buf - go _ ('.':rest) = go [] rest - go buf (x:xs) = go (buf ++ [x]) xs - (EApp templateF templateBody, EApp seenF seenBody) -> - unifyAll freeVars [templateF, templateBody] [seenF, seenBody] - (ENeg rw, ENeg seen) -> - unify freeVars rw seen - (EBin op rwLeft rwRight, EBin op' seenLeft seenRight) | op == op' -> - unifyAll freeVars [rwLeft, rwRight] [seenLeft, seenRight] - (EIte cond rwLeft rwRight, EIte seenCond seenLeft seenRight) -> - unifyAll freeVars [cond, rwLeft, rwRight] [seenCond, seenLeft, seenRight] - (ECst rw _, ECst seen _) -> - unify freeVars rw seen - (ETApp rw _, ETApp seen _) -> - unify freeVars rw seen - (ETAbs rw _, ETAbs seen _) -> - unify freeVars rw seen - (PAnd rw, PAnd seen ) -> - unifyAll freeVars rw seen - (POr rw, POr seen ) -> - unifyAll freeVars rw seen - (PNot rw, PNot seen) -> - unify freeVars rw seen - (PImp templateF templateBody, PImp seenF seenBody) -> - unifyAll freeVars [templateF, templateBody] [seenF, seenBody] - (PIff templateF templateBody, PIff seenF seenBody) -> - unifyAll freeVars [templateF, templateBody] [seenF, seenBody] - (PAtom rel templateF templateBody, PAtom rel' seenF seenBody) | rel == rel' -> - unifyAll freeVars [templateF, templateBody] [seenF, seenBody] - (PAll _ rw, PAll _ seen) -> - unify freeVars rw seen - (PExist _ rw, PExist _ seen) -> - unify freeVars rw seen - (PGrad _ _ _ rw, PGrad _ _ _ seen) -> - unify freeVars rw seen - (ECoerc _ _ rw, ECoerc _ _ seen) -> - unify freeVars rw seen - _ -> Nothing + -- otherwise discard the seen casts + (template', _) -> case (template', dropECst seenExpr) of + (EVar lhs, EVar rhs) | removeModName lhs == removeModName rhs -> + Just (Su M.empty) + where + removeModName ts = go "" (symbolString ts) where + go buf [] = buf + go _ ('.':rest) = go [] rest + go buf (x:xs) = go (buf ++ [x]) xs + (EApp templateF templateBody, EApp seenF seenBody) -> + unifyAll freeVars [templateF, templateBody] [seenF, seenBody] + (ENeg rw, ENeg seen) -> + unify freeVars rw seen + (EBin op rwLeft rwRight, EBin op' seenLeft seenRight) | op == op' -> + unifyAll freeVars [rwLeft, rwRight] [seenLeft, seenRight] + (EIte cond rwLeft rwRight, EIte seenCond seenLeft seenRight) -> + unifyAll freeVars [cond, rwLeft, rwRight] [seenCond, seenLeft, seenRight] + (ECst rw _, seen) -> + unify freeVars rw seen + (ETApp rw _, ETApp seen _) -> + unify freeVars rw seen + (ETAbs rw _, ETAbs seen _) -> + unify freeVars rw seen + (PAnd rw, PAnd seen ) -> + unifyAll freeVars rw seen + (POr rw, POr seen ) -> + unifyAll freeVars rw seen + (PNot rw, PNot seen) -> + unify freeVars rw seen + (PImp templateF templateBody, PImp seenF seenBody) -> + unifyAll freeVars [templateF, templateBody] [seenF, seenBody] + (PIff templateF templateBody, PIff seenF seenBody) -> + unifyAll freeVars [templateF, templateBody] [seenF, seenBody] + (PAtom rel templateF templateBody, PAtom rel' seenF seenBody) | rel == rel' -> + unifyAll freeVars [templateF, templateBody] [seenF, seenBody] + (PAll _ rw, PAll _ seen) -> + unify freeVars rw seen + (PExist _ rw, PExist _ seen) -> + unify freeVars rw seen + (PGrad _ _ _ rw, PGrad _ _ _ seen) -> + unify freeVars rw seen + (ECoerc _ _ rw, ECoerc _ _ seen) -> + unify freeVars rw seen + _ -> Nothing diff --git a/src/Language/Fixpoint/Solver/Sanitize.hs b/src/Language/Fixpoint/Solver/Sanitize.hs --- a/src/Language/Fixpoint/Solver/Sanitize.hs +++ b/src/Language/Fixpoint/Solver/Sanitize.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver.Sanitize ( -- * Transform FInfo to enforce invariants sanitize @@ -16,13 +18,13 @@ ) where import Language.Fixpoint.Types.PrettyPrint -import Language.Fixpoint.Types.Visitor +import Language.Fixpoint.Types.Visitor import Language.Fixpoint.SortCheck (elaborate, applySorts, isFirstOrder) --- import Language.Fixpoint.Defunctionalize +-- import Language.Fixpoint.Defunctionalize import qualified Language.Fixpoint.Misc as Misc import qualified Language.Fixpoint.Types as F import Language.Fixpoint.Types.Config (Config) -import qualified Language.Fixpoint.Types.Config as Cfg +import qualified Language.Fixpoint.Types.Config as Cfg import qualified Language.Fixpoint.Types.Errors as E import qualified Language.Fixpoint.Smt.Theories as Thy import Language.Fixpoint.Graph (kvEdges, CVertex (..)) @@ -88,11 +90,11 @@ cancelCoercion :: F.SInfo a -> F.SInfo a cancelCoercion = mapExpr (trans (defaultVisitor { txExpr = go }) () ()) - where - go _ (F.ECoerc t1 t2 (F.ECoerc t2' t1' e)) + where + go _ (F.ECoerc t1 t2 (F.ECoerc t2' t1' e)) | t1 == t1' && t2 == t2' - = e - go _ e = e + = e + go _ e = e -------------------------------------------------------------------------------- -- | `eliminateEta` converts equations of the form f x = g x into f = g @@ -100,13 +102,13 @@ eliminateEta :: Config -> F.SInfo a -> F.SInfo a -------------------------------------------------------------------------------- eliminateEta cfg si - | Cfg.etaElim cfg + | Cfg.etaElim cfg , Cfg.oldPLE cfg = si { F.ae = ae' } - | Cfg.etaElim cfg + | Cfg.etaElim cfg = si { F.ae = (ae {F.aenvEqs = etaElimNEW `fmap` F.aenvEqs ae }) } - | otherwise - = si + | otherwise + = si where ae' = ae {F.aenvEqs = eqs} ae = F.ae si @@ -153,12 +155,12 @@ , F.eqBody = F.eApps f1 args1'} where argsAndSorts = F.eqArgs eq args = fst <$> argsAndSorts - args0 = reverse args + args0 = reverse args sort = F.eqSort eq - + fapp :: F.Expr -> (F.Expr, [F.Symbol]) fapp ee = fromMaybe (ee, []) (fapp' ee) - + fapp' :: F.Expr -> Maybe (F.Expr, [F.Symbol]) fapp' (F.EApp e0 (F.EVar arg)) = do (fvar, args) <- fapp' e0 @@ -313,7 +315,7 @@ initEnv si w = F.fromListSEnv [ (bind i, i) | i <- is ] where is = F.elemsIBindEnv $ F.wenv w - bind i = fst (F.lookupBindEnv i be) + bind i = Misc.fst3 (F.lookupBindEnv i be) be = F.bs si -------------------------------------------------------------------------------- @@ -337,9 +339,10 @@ where be = F.bs fi ids = F.elemsIBindEnv $ F.senv c - cDom = [fst $ F.lookupBindEnv i be | i <- ids] - cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . snd $ F.lookupBindEnv i be | i <- ids] - fv = (`Misc.nubDiff` cDom) . filter (not . known) $ cRng + cDom = [Misc.fst3 $ F.lookupBindEnv i be | i <- ids] + cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . Misc.snd3 $ F.lookupBindEnv i be | i <- ids] + ++ F.syms (F.crhs c) + fv = (`Misc.nubDiff` cDom) . filter (not . known) $ cRng badCs :: Misc.ListNE (F.SimpC a, [F.Symbol]) -> E.Error badCs = E.catErrors . map (E.errFreeVarInConstraint . Misc.mapFst F.subcId) @@ -350,7 +353,7 @@ banIrregularData :: F.SInfo a -> SanitizeM (F.SInfo a) banIrregularData fi = Misc.applyNonNull (Right fi) (Left . badDataDecl) bads where - bads = F.checkRegular (F.ddecls fi ) + bads = F.checkRegular (F.ddecls fi ) badDataDecl :: Misc.ListNE F.DataDecl -> E.Error badDataDecl ds = E.catErrors [ E.errBadDataDecl d | d <- ds ] @@ -363,8 +366,8 @@ banQualifFreeVars fi = Misc.applyNonNull (Right fi) (Left . badQuals) bads where bads = [ (q, xs) | q <- F.quals fi, let xs = free q, not (null xs) ] - free q = filter (not . isLit) (F.syms q) - isLit x = F.memberSEnv x (F.gLits fi) + free q = filter (not . isLit) (F.syms q) + isLit x = F.memberSEnv x (F.gLits fi) -- lits = fst <$> F.toListSEnv (F.gLits fi) -- free q = S.toList $ F.syms (F.qBody q) `nubDiff` (lits ++ F.prims ++ F.syms (F.qpSym <$> F.qParams q)) @@ -394,26 +397,26 @@ -- | symbol |-> sort for EVERY variable in the SInfo; 'symbolEnv' can ONLY be -- called with **sanitized** environments (post the uniqification etc.) or -- else you get duplicate sorts and other such errors. --- We do this peculiar dance with `env0` to extract the apply-sorts from the --- function definitions inside the `AxiomEnv` which cannot be elaborated as +-- We do this peculiar dance with `env0` to extract the apply-sorts from the +-- function definitions inside the `AxiomEnv` which cannot be elaborated as -- it makes it hard to actually find the fundefs within (breaking PLE.) -------------------------------------------------------------------------------- symbolEnv :: Config -> F.SInfo a -> F.SymEnv symbolEnv cfg si = F.symEnv sEnv tEnv ds lits (ts ++ ts') where - ts' = applySorts ae' + ts' = applySorts ae' ae' = elaborate (F.atLoc E.dummySpan "symbolEnv") env0 (F.ae si) env0 = F.symEnv sEnv tEnv ds lits ts tEnv = Thy.theorySymbols ds ds = F.ddecls si ts = Misc.hashNub (applySorts si ++ [t | (_, t) <- F.toListSEnv sEnv]) - sEnv = (F.tsSort <$> tEnv) `mappend` (F.fromListSEnv xts) + sEnv = (F.tsSort <$> tEnv) `mappend` F.fromListSEnv xts xts = symbolSorts cfg si ++ alits lits = F.dLits si `F.unionSEnv'` F.fromListSEnv alits alits = litsAEnv $ F.ae si litsAEnv :: F.AxiomEnv -> [(F.Symbol, F.Sort)] -litsAEnv ae = zip (F.symbol <$> (symConsts ae)) (repeat $ F.strSort) +litsAEnv ae = zip (F.symbol <$> symConsts ae) (repeat F.strSort) symbolSorts :: Config -> F.GInfo c a -> [(F.Symbol, F.Sort)] symbolSorts cfg fi = either E.die id $ symbolSorts' cfg fi @@ -424,17 +427,16 @@ normalize = fmap (map (unShadow txFun dm)) dm = M.fromList defs defs = F.toListSEnv . F.gLits $ fi - txFun - | True = id + txFun = id unShadow :: (F.Sort -> F.Sort) -> M.HashMap F.Symbol a -> (F.Symbol, F.Sort) -> (F.Symbol, F.Sort) unShadow tx dm (x, t) - | M.member x dm = (x, t) - | otherwise = (x, tx t) + | M.member x dm = (x, t) + | otherwise = (x, tx t) _defuncSort :: F.Sort -> F.Sort -_defuncSort (F.FFunc {}) = F.funcSort -_defuncSort t = t +_defuncSort F.FFunc{} = F.funcSort +_defuncSort t = t compact :: [(F.Symbol, F.Sort)] -> Either E.Error [(F.Symbol, F.Sort)] compact xts @@ -466,7 +468,7 @@ , nest 4 (pprint y) ] -------------------------------------------------------------------------------- -symBinds :: F.BindEnv -> [SymBinds] +symBinds :: F.BindEnv a -> [SymBinds] -------------------------------------------------------------------------------- symBinds = {- THIS KILLS ELEM: tracepp "symBinds" . -} M.toList @@ -476,8 +478,8 @@ type SymBinds = (F.Symbol, [(F.Sort, [F.BindId])]) -binders :: F.BindEnv -> [(F.Symbol, (F.Sort, F.BindId))] -binders be = [(x, (F.sr_sort t, i)) | (i, x, t) <- F.bindEnvToList be] +binders :: F.BindEnv a -> [(F.Symbol, (F.Sort, F.BindId))] +binders be = [(x, (F.sr_sort t, i)) | (i, (x, t, _)) <- F.bindEnvToList be] -------------------------------------------------------------------------------- @@ -487,9 +489,10 @@ -------------------------------------------------------------------------------- dropFuncSortedShadowedBinders fi = dropBinders ok (const True) fi where - ok x t = (M.member x defs) ==> (F.allowHO fi || isFirstOrder t) + ok x t = M.member x defs ==> (F.allowHO fi || isFirstOrder t) defs = M.fromList $ F.toListSEnv $ F.gLits fi +infixl 9 ==> (==>) :: Bool -> Bool -> Bool p ==> q = not p || q @@ -550,12 +553,13 @@ deleteWfCBinds :: [F.BindId] -> F.WfC a -> F.WfC a deleteWfCBinds bs wf = wf { F.wenv = foldr F.deleteIBindEnv (F.wenv wf) bs } -filterBindEnv :: KeepBindF -> F.BindEnv -> (F.BindEnv, [F.BindId]) -filterBindEnv f be = (F.bindEnvFromList keep, discard') +filterBindEnv :: KeepBindF -> F.BindEnv a -> (F.BindEnv a, [F.BindId]) +filterBindEnv f be = (keepBindEnv , discard') where + keepBindEnv = F.bindEnvFromList [(i, (x, sr, a)) | (i, (x, sr, a)) <- keep] (keep, discard) = L.partition f' $ F.bindEnvToList be - discard' = Misc.fst3 <$> discard - f' (_, x, t) = f x (F.sr_sort t) + discard' = fst <$> discard + f' (_, (x, t, _)) = f x (F.sr_sort t) --------------------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/Simplify.hs b/src/Language/Fixpoint/Solver/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Simplify.hs @@ -0,0 +1,163 @@ +-------------------------------------------------------------------------------- +-- | This module contains common functions used in the implementations of +-- Simplifiable Expr in both Interpreter.hs and PLE.hs. +-------------------------------------------------------------------------------- + +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Language.Fixpoint.Solver.Simplify (applyBooleanFolding, applyConstantFolding, applySetFolding, isSetPred) where + +import Language.Fixpoint.Types hiding (simplify) +import Language.Fixpoint.Smt.Theories +import Data.Hashable +import qualified Data.HashSet as S +import qualified Data.Maybe as Mb + + +applyBooleanFolding :: Brel -> Expr -> Expr -> Expr +applyBooleanFolding brel e1 e2 = + case (e1, e2) of + (ECon (R left), ECon (R right)) -> + Mb.fromMaybe e (bfR brel left right) + (ECon (R left), ECon (I right)) -> + Mb.fromMaybe e (bfR brel left (fromIntegral right)) + (ECon (I left), ECon (R right)) -> + Mb.fromMaybe e (bfR brel (fromIntegral left) right) + (ECon (I left), ECon (I right)) -> + Mb.fromMaybe e (bfI brel left right) + _ -> if isTautoPred e then PTrue else + if isContraPred e then PFalse else e + where + e = PAtom brel e1 e2 + + getOp :: Ord a => Brel -> (a -> a -> Bool) + getOp Gt = (>) + getOp Ge = (>=) + getOp Lt = (<) + getOp Le = (<=) + getOp Eq = (==) + getOp Ne = (/=) + getOp Ueq = (==) + getOp Une = (/=) + + bfR :: Brel -> Double -> Double -> Maybe Expr + bfR brel left right = if getOp brel left right then Just PTrue else Just PFalse + + bfI :: Brel -> Integer -> Integer -> Maybe Expr + bfI brel left right = if getOp brel left right then Just PTrue else Just PFalse + + +-- | Replace constant integer and floating point expressions by constant values +-- where possible. +applyConstantFolding :: Bop -> Expr -> Expr -> Expr +applyConstantFolding bop e1 e2 = + case (dropECst e1, dropECst e2) of + (ECon (R left), ECon (R right)) -> + Mb.fromMaybe e (cfR bop left right) + (ECon (R left), ECon (I right)) -> + Mb.fromMaybe e (cfR bop left (fromIntegral right)) + (ECon (I left), ECon (R right)) -> + Mb.fromMaybe e (cfR bop (fromIntegral left) right) + (ECon (I left), ECon (I right)) -> + Mb.fromMaybe e (cfI bop left right) + (EBin Mod _ _ , _) -> e + (EBin bop1 e11 (dropECst -> ECon (R left)), ECon (R right)) + | bop == bop1 -> maybe e (EBin bop e11) (cfR (rop bop) left right) + | otherwise -> e + (EBin bop1 e11 (dropECst -> ECon (R left)), ECon (I right)) + | bop == bop1 -> maybe e (EBin bop e11) (cfR (rop bop) left (fromIntegral right)) + | otherwise -> e + (EBin bop1 e11 (dropECst -> ECon (I left)), ECon (R right)) + | bop == bop1 -> maybe e (EBin bop e11) (cfR (rop bop) (fromIntegral left) right) + | otherwise -> e + (EBin bop1 e11 (dropECst -> ECon (I left)), ECon (I right)) + | bop == bop1 -> maybe e (EBin bop e11) (cfI (rop bop) left right) + | otherwise -> e + _ -> e + where + + rop :: Bop -> Bop + rop Plus = Plus + rop Minus = Plus + rop Times = Times + rop Div = Times + rop RTimes = RTimes + rop RDiv = RTimes + rop Mod = Mod + + e = EBin bop e1 e2 + + getOp :: Num a => Bop -> Maybe (a -> a -> a) + getOp Minus = Just (-) + getOp Plus = Just (+) + getOp Times = Just (*) + getOp RTimes = Just (*) + getOp _ = Nothing + + cfR :: Bop -> Double -> Double -> Maybe Expr + cfR bop left right = fmap go (getOp' bop) + where + go f = ECon $ R $ f left right + + getOp' Div = Just (/) + getOp' RDiv = Just (/) + getOp' op = getOp op + + cfI :: Bop -> Integer -> Integer -> Maybe Expr + cfI bop left right = fmap go (getOp' bop) + where + go f = ECon $ I $ f left right + + getOp' Mod = Just mod + getOp' op = getOp op + +isSetPred :: Expr -> Bool +isSetPred (EVar s) | s == setEmp = True +isSetPred (EApp e1 _) = case e1 of + (EVar s) | s == setMem || s == setSub -> True + _ -> False +isSetPred _ = False + +-- Note: this is currently limited to sets of integer constants +applySetFolding :: Expr -> Expr -> Expr +applySetFolding e1 e2 = case e1 of + (EVar s) | s == setEmp + -> maybe e (fromBool . S.null) (evalSetI e2) + (EApp (EVar s) e1') | s == setMem + -> maybe e fromBool (S.member <$> getInt e1' <*> evalSetI e2) + | s == setEmp + -> maybe e (fromBool . S.null) (S.difference <$> evalSetI e1' <*> evalSetI e2) + | otherwise + -> e + _ -> e + where + e = EApp e1 e2 + + fromBool True = PTrue + fromBool False = PFalse + + getInt :: Expr -> Maybe Integer + getInt (ECon (I n)) = Just n + getInt _ = Nothing + + getOp :: (Eq a, Hashable a) => Symbol -> Maybe (S.HashSet a -> S.HashSet a -> S.HashSet a) + getOp s | s == setCup = Just S.union + | s == setCap = Just S.intersection + | s == setDif = Just S.difference + | otherwise = Nothing + + evalSetI :: Expr -> Maybe (S.HashSet Integer) + evalSetI (EApp e1 e2) = case e1 of + (EVar s) | s == setEmpty -> Just S.empty + | s == setSng -> case e2 of + (ECon (I n)) -> Just $ S.singleton n + _ -> Nothing + (EApp (EVar f) e1') -> getOp f <*> evalSetI e1' <*> evalSetI e2 + _ -> Nothing + evalSetI _ = Nothing + diff --git a/src/Language/Fixpoint/Solver/Solution.hs b/src/Language/Fixpoint/Solver/Solution.hs --- a/src/Language/Fixpoint/Solver/Solution.hs +++ b/src/Language/Fixpoint/Solver/Solution.hs @@ -1,9 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver.Solution ( -- * Create Initial Solution init @@ -19,14 +20,12 @@ import Control.Parallel.Strategies import Control.Arrow (second, (***)) +import Control.Monad (void) import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M import qualified Data.List as L import Data.Maybe (fromMaybe, maybeToList, isNothing) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - +import qualified Data.Bifunctor as Bifunctor (second) import Language.Fixpoint.Types.PrettyPrint () import Language.Fixpoint.Types.Visitor as V import qualified Language.Fixpoint.SortCheck as So @@ -52,7 +51,7 @@ init cfg si ks_ = Sol.fromList senv mempty keqs [] mempty ebs xEnv where keqs = map (refine si qcs genv) ws `using` parList rdeepseq - qcs = {- trace ("init-qs-size " ++ show (length ws, length qs_, M.keys qcs_)) $ -} qcs_ + qcs = {- trace ("init-qs-size " ++ show (length ws, length qs_, M.keys qcs_)) $ -} qcs_ qcs_ = mkQCluster qs_ qs_ = F.quals si ws = [ w | (k, w) <- M.toList (F.ws si), not (isGWfc w), k `S.member` ks ] @@ -60,11 +59,11 @@ genv = instConstants si senv = symbolEnv cfg si ebs = ebindInfo si - xEnv = F.fromListSEnv [ (x, (i, F.sr_sort sr)) | (i,x,sr) <- F.bindEnvToList (F.bs si)] + xEnv = F.fromListSEnv [ (x, (i, F.sr_sort sr)) | (i,(x,sr,_)) <- F.bindEnvToList (F.bs si)] -------------------------------------------------------------------------------- -- | [NOTE:qual-cluster] It is wasteful to perform instantiation *individually* --- on each qualifier, as many qualifiers have "equivalent" parameters, and +-- on each qualifier, as many qualifiers have "equivalent" parameters, and -- so have the "same" instances in an environment. To exploit this structure, -- -- 1. Group the [Qualifier] into a QCluster @@ -79,7 +78,7 @@ mkQCluster = Misc.groupMap qualSig qualSig :: Qualifier -> QCSig -qualSig q = [ p { F.qpSym = F.dummyName } | p <- F.qParams q ] +qualSig q = [ p { F.qpSym = F.dummyName } | p <- F.qParams q ] -------------------------------------------------------------------------------- @@ -107,13 +106,13 @@ -> F.SEnv F.Sort -> F.Symbol -> F.Sort - -> QCluster + -> QCluster -> Sol.QBind -------------------------------------------------------------------------------- -instK ho env v t qc = Sol.qb . unique $ - [ Sol.eQual q xs +instK ho env v t qc = Sol.qb . unique $ + [ Sol.eQual q xs | (sig, qs) <- M.toList qc - , xs <- instKSig ho env v t sig + , xs <- instKSig ho env v t sig , q <- qs ] @@ -124,27 +123,27 @@ -> F.SEnv F.Sort -> F.Symbol -> F.Sort - -> QCSig + -> QCSig -> [[F.Symbol]] -instKSig ho env v t qsig = do +instKSig _ _ _ _ [] = error "Empty qsig in Solution.instKSig" +instKSig ho env v t (qp:qps) = do (su0, i0, qs0) <- candidatesP senv [(0, t, [v])] qp - ixs <- matchP senv tyss [(i0, qs0)] (applyQPP su0 <$> qps) + ixs <- matchP senv tyss [(i0, qs0)] (applyQPP su0 <$> qps) -- return $ F.notracepp msg (reverse ixs) - ys <- instSymbol tyss (tail $ reverse ixs) + ys <- instSymbol tyss (tail $ reverse ixs) return (v:ys) where -- msg = "instKSig " ++ F.showpp qsig - qp : qps = qsig tyss = zipWith (\i (t, ys) -> (i, t, ys)) [1..] (instCands ho env) senv = (`F.lookupSEnvWithDistance` env) instSymbol :: [(SortIdx, a, [F.Symbol])] -> [(SortIdx, QualPattern)] -> [[F.Symbol]] -instSymbol tyss = go +instSymbol tyss = go where m = M.fromList [(i, ys) | (i,_,ys) <- tyss] - go [] = + go [] = return [] - go ((i,qp):is) = do + go ((i,qp):is) = do y <- M.lookupDefault [] i m qsu <- maybeToList (matchSym qp y) ys <- go [ (i', applyQPSubst qsu qp') | (i', qp') <- is] @@ -156,9 +155,9 @@ -- -> F.Sort -- -> F.Qualifier -- -> [Sol.EQual] --- instKQ ho env v t q = do +-- instKQ ho env v t q = do -- (su0, qsu0, v0) <- candidates senv [(t, [v])] qp --- xs <- match senv tyss [v0] (applyQP su0 qsu0 <$> qps) +-- xs <- match senv tyss [v0] (applyQP su0 qsu0 <$> qps) -- return $ Sol.eQual q (F.notracepp msg (reverse xs)) -- where -- msg = "instKQ " ++ F.showpp (F.qName q) ++ F.showpp (F.qParams q) @@ -176,18 +175,18 @@ type SortIdx = Int -matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] -> +matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] -> [[(SortIdx, QualPattern)]] matchP env tyss = go - where + where go' !i !p !is !qps = go ((i, p):is) qps go is (qp : qps) = do (su, i, pat) <- candidatesP env tyss qp go' i pat is (applyQPP su <$> qps) go is [] = return is applyQPP :: So.TVSubst -> F.QualParam -> F.QualParam -applyQPP su qp = qp - { qpSort = So.apply su (qpSort qp) +applyQPP su qp = qp + { qpSort = So.apply su (qpSort qp) } -- match :: So.Env -> [(F.Sort, [F.Symbol])] -> [F.Symbol] -> [F.QualParam] -> [[F.Symbol]] @@ -198,17 +197,17 @@ -- = return xs -- applyQP :: So.TVSubst -> QPSubst -> F.QualParam -> F.QualParam --- applyQP su qsu qp = qp --- { qpSort = So.apply su (qpSort qp) --- , qpPat = applyQPSubst qsu (qpPat qp) +-- applyQP su qsu qp = qp +-- { qpSort = So.apply su (qpSort qp) +-- , qpPat = applyQPSubst qsu (qpPat qp) -- } -------------------------------------------------------------------------------- -candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam -> +candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam -> [(So.TVSubst, SortIdx, QualPattern)] -------------------------------------------------------------------------------- candidatesP env tyss x = - [(su, idx, qPat) + [(su, idx, qPat) | (idx, t,_) <- tyss , su <- maybeToList (So.unifyFast mono env xt t) ] @@ -216,42 +215,42 @@ xt = F.qpSort x qPat = F.qpPat x mono = So.isMono xt - + -- -------------------------------------------------------------------------------- --- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam +-- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam -- -> [(So.TVSubst, QPSubst, F.Symbol)] -- -------------------------------------------------------------------------------- -- candidates env tyss x = -- traceShow _msg -- [(su, qsu, y) | (t, ys) <- tyss -- , su <- maybeToList (So.unifyFast mono env xt t) -- , y <- ys --- , qsu <- maybeToList (matchSym x y) +-- , qsu <- maybeToList (matchSym x y) -- ] -- where -- xt = F.qpSort x -- mono = So.isMono xt -- _msg = "candidates tyss :=" ++ F.showpp tyss ++ "tx := " ++ F.showpp xt -matchSym :: F.QualPattern -> F.Symbol -> Maybe QPSubst +matchSym :: F.QualPattern -> F.Symbol -> Maybe QPSubst matchSym qp y' = case qp of - F.PatPrefix s i -> JustSub i <$> F.stripPrefix s y - F.PatSuffix i s -> JustSub i <$> F.stripSuffix s y - F.PatNone -> Just NoSub - F.PatExact s -> if s == y then Just NoSub else Nothing - where + F.PatPrefix s i -> JustSub i <$> F.stripPrefix s y + F.PatSuffix i s -> JustSub i <$> F.stripSuffix s y + F.PatNone -> Just NoSub + F.PatExact s -> if s == y then Just NoSub else Nothing + where y = F.tidySymbol y' -data QPSubst = NoSub | JustSub Int F.Symbol +data QPSubst = NoSub | JustSub Int F.Symbol -applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern -applyQPSubst (JustSub i x) (F.PatPrefix s j) - | i == j = F.PatExact (F.mappendSym s x) -applyQPSubst (JustSub i x) (F.PatSuffix j s) - | i == j = F.PatExact (F.mappendSym x s) -applyQPSubst _ p - = p +applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern +applyQPSubst (JustSub i x) (F.PatPrefix s j) + | i == j = F.PatExact (F.mappendSym s x) +applyQPSubst (JustSub i x) (F.PatSuffix j s) + | i == j = F.PatExact (F.mappendSym x s) +applyQPSubst _ p + = p -------------------------------------------------------------------------------- okInst :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> Sol.EQual -> Bool @@ -260,7 +259,7 @@ where sr = F.RR t (F.Reft (v, p)) p = Sol.eqPred eq - tc = So.checkSorted (F.srcSpan eq) env sr + tc = So.checkSorted (F.srcSpan eq) env sr -- _msg = printf "okInst: t = %s, eq = %s, env = %s" (F.showpp t) (F.showpp eq) (F.showpp env) @@ -271,7 +270,7 @@ lhsPred :: (F.Loc a) => F.IBindEnv - -> F.BindEnv + -> F.BindEnv a -> Sol.Solution -> F.SimpC a -> F.Expr @@ -282,10 +281,10 @@ ci = sid c _msg = "LhsPred for id = " ++ show (sid c) ++ " with SOLUTION = " ++ F.showpp s -data CombinedEnv = CEnv +data CombinedEnv a = CEnv { ceCid :: !Cid - , ceBEnv :: !F.BindEnv - , ceIEnv :: !F.IBindEnv + , ceBEnv :: !(F.BindEnv a) + , ceIEnv :: !F.IBindEnv , ceSpan :: !F.SrcSpan -- | These are the bindings that the smt solver knows about and can be -- referred as @EVar (bindSymbol )@ instead of serializing them @@ -293,13 +292,13 @@ , ceBindingsInSmt :: !F.IBindEnv } -instance F.Loc CombinedEnv where +instance F.Loc (CombinedEnv a) where srcSpan = ceSpan type Cid = Maybe Integer type ExprInfo = (F.Expr, KInfo) -apply :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ExprInfo +apply :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ExprInfo apply g s bs = (F.conj (pks:ps), kI) -- see [NOTE: pAnd-SLOW] where -- Clear the "known" bindings for applyKVars, since it depends on @@ -309,23 +308,23 @@ (ps, ks, _) = envConcKVars g s bs -envConcKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ([F.Expr], [F.KVSub], [F.KVSub]) +envConcKVars :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ([F.Expr], [F.KVSub], [F.KVSub]) envConcKVars g s bs = (concat pss, concat kss, L.nubBy (\x y -> F.ksuKVar x == F.ksuKVar y) $ concat gss) where (pss, kss, gss) = unzip3 [ F.notracepp ("sortedReftConcKVars" ++ F.showpp sr) $ F.sortedReftConcKVars x sr | (x, sr) <- xrs ] xrs = lookupBindEnvExt g s <$> is is = F.elemsIBindEnv bs -lookupBindEnvExt :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> (F.Symbol, F.SortedReft) +lookupBindEnvExt :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.BindId -> (F.Symbol, F.SortedReft) lookupBindEnvExt g s i | Just p <- ebSol g {ceBindingsInSmt = F.emptyIBindEnv} s i = (x, sr { F.sr_reft = F.Reft (x, p) }) | F.memberIBindEnv i (ceBindingsInSmt g) = (x, sr { F.sr_reft = F.Reft (x, F.EVar (F.bindSymbol (fromIntegral i)))}) | otherwise = (x, sr) - where - (x, sr) = F.lookupBindEnv i (ceBEnv g) + where + (x, sr, _) = F.lookupBindEnv i (ceBEnv g) -ebSol :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> Maybe F.Expr +ebSol :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.BindId -> Maybe F.Expr ebSol g s i = case M.lookup i sebds of Just (Sol.EbSol p) -> Just p Just (Sol.EbDef cs _) -> Just $ F.PAnd (cSol <$> cs) @@ -334,16 +333,16 @@ sebds = Sol.sEbd s ebReft s (i,c) = exElim (Sol.sxEnv s) (senv c) i (ebindReft g s c) - cSol c = if sid c == ceCid g + cSol c = if sid c == ceCid g then F.PFalse else ebReft s' (i, c) s' = s { Sol.sEbd = M.insert i Sol.EbIncr sebds } -ebindReft :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.SimpC () -> F.Pred +ebindReft :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.SimpC () -> F.Pred ebindReft g s c = F.pAnd [ fst $ apply g' s bs, F.crhs c ] where - g' = g { ceCid = sid c, ceIEnv = bs } + g' = g { ceCid = sid c, ceIEnv = bs } bs = F.senv c exElim :: F.SEnv (F.BindId, F.Sort) -> F.IBindEnv -> F.BindId -> F.Pred -> F.Pred @@ -355,17 +354,17 @@ , xi < yi , yi `F.memberIBindEnv` ienv ] -applyKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> [F.KVSub] -> ExprInfo +applyKVars :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> [F.KVSub] -> ExprInfo applyKVars g s = mrExprInfos (applyKVar g s) F.pAndNoDedup mconcat -applyKVar :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> ExprInfo +applyKVar :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> ExprInfo applyKVar g s ksu = case Sol.lookup s (F.ksuKVar ksu) of Left cs -> hypPred g s ksu cs Right eqs -> (F.pAndNoDedup $ fst <$> Sol.qbPreds msg s (F.ksuSubst ksu) eqs, mempty) -- TODO: don't initialize kvars that have a hyp solution where msg = "applyKVar: " ++ show (ceCid g) -nonCutsResult :: F.BindEnv -> Sol.Sol a Sol.QBind -> M.HashMap F.KVar F.Expr +nonCutsResult :: F.BindEnv ann -> Sol.Sol a Sol.QBind -> M.HashMap F.KVar F.Expr nonCutsResult be s = let g = CEnv Nothing be F.emptyIBindEnv F.dummySpan F.emptyIBindEnv in M.mapWithKey (mkNonCutsExpr g) $ Sol.sHyp s @@ -389,7 +388,7 @@ -- particular use of the KVar. Thus @cubePred@ produces a different -- expression for every use site of the kvar, while here we produce one -- expression for all the uses. -bareCubePred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVar -> Sol.Cube -> F.Expr +bareCubePred :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVar -> Sol.Cube -> F.Expr bareCubePred g s k c = let bs = Sol.cuBinds c su = Sol.cuSubst c @@ -401,7 +400,7 @@ (p, _kI) = apply g' s bs' in F.pExist (xts ++ yts) (psu &.& p) -hypPred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Hyp -> ExprInfo +hypPred :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Hyp -> ExprInfo hypPred g s ksu hyp = F.pOr *** mconcatPlus $ unzip $ cubePred g s ksu <$> hyp {- | `cubePred g s k su c` returns the predicate for @@ -426,7 +425,7 @@ elab = So.elaborate (F.atLoc sp "elabExist") env env = Sol.sEnv s -cubePred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> ExprInfo +cubePred :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> ExprInfo cubePred g s ksu c = (F.notracepp "cubePred" $ elabExist sp s xts (psu &.& p), kI) where sp = F.srcSpan g @@ -441,7 +440,7 @@ -- The output is a tuple, `(xts, psu, p, kI)` such that the actual predicate -- we want is `Exists xts. (psu /\ p)`. -cubePredExc :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> F.IBindEnv +cubePredExc :: CombinedEnv ann -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> F.IBindEnv -> ((Binders, F.Pred, F.Pred), KInfo) cubePredExc g s ksu c bs' = (cubeP, extendKInfo kI (Sol.cuTag c)) @@ -485,7 +484,7 @@ 2. are binders corresponding to sorts (e.g. `a : num`, currently used to hack typeclasses current.) -} -substElim :: F.SymEnv -> F.SEnv F.Sort -> CombinedEnv -> F.KVar -> F.Subst -> ([(F.Symbol, F.Sort)], F.Pred) +substElim :: F.SymEnv -> F.SEnv F.Sort -> CombinedEnv a -> F.KVar -> F.Subst -> ([(F.Symbol, F.Sort)], F.Pred) substElim syEnv sEnv g _ (F.Su m) = (xts, p) where p = F.pAnd [ mkSubst sp syEnv x (substSort sEnv frees x t) e t | (x, e, t) <- xets ] @@ -507,7 +506,7 @@ mkSubst :: F.SrcSpan -> F.SymEnv -> F.Symbol -> F.Sort -> F.Expr -> F.Sort -> F.Expr mkSubst sp env x tx ey ty | tx == ty = F.EEq ex ey - | otherwise = {- F.tracepp _msg -} (F.EEq ex' ey') + | otherwise = {- F.tracepp _msg -} F.EEq ex' ey' where _msg = "mkSubst-DIFF:" ++ F.showpp (tx, ty) ++ F.showpp (ex', ey') ex = F.expr x @@ -522,28 +521,14 @@ isClass F.FFrac = True isClass _ = False ---badExpr :: CombinedEnv -> F.KVar -> F.Expr -> a ---badExpr g@(i,_,_) k e - -- = errorstar $ "substSorts has a badExpr: " - -- ++ show e - -- ++ " in cid = " - -- ++ show i - -- ++ " for kvar " ++ show k - -- ++ " in env \n" - -- ++ show (combinedSEnv g) - --- substPred :: F.Subst -> F.Pred --- substPred (F.Su m) = F.pAnd [ F.PAtom F.Eq (F.eVar x) e | (x, e) <- M.toList m] - -combinedSEnv :: CombinedEnv -> F.SEnv F.Sort +combinedSEnv :: CombinedEnv a -> F.SEnv F.Sort combinedSEnv g = F.sr_sort <$> F.fromListSEnv (F.envCs be bs) - where - be = ceBEnv g - bs = ceIEnv g + where + be = ceBEnv g + bs = ceIEnv g -addCEnv :: CombinedEnv -> F.IBindEnv -> CombinedEnv +addCEnv :: CombinedEnv a -> F.IBindEnv -> CombinedEnv a addCEnv g bs' = g { ceIEnv = F.unionIBindEnv (ceIEnv g) bs' } --- addCEnv (x, be, bs) bs' = (x, be, F.unionIBindEnv bs bs') delCEnv :: Sol.Sol a Sol.QBind -> F.KVar -> F.IBindEnv -> F.IBindEnv @@ -551,7 +536,7 @@ where _kbs = Misc.safeLookup "delCEnv" k (Sol.sScp s) -symSorts :: CombinedEnv -> F.IBindEnv -> [(F.Symbol, F.Sort)] +symSorts :: CombinedEnv a -> F.IBindEnv -> [(F.Symbol, F.Sort)] symSorts g bs = second F.sr_sort <$> F.envCs (ceBEnv g) bs _noKvars :: F.Expr -> Bool @@ -596,43 +581,41 @@ (es, is) = unzip $ map mF xs -------------------------------------------------------------------------------- --- | `ebindInfo` constructs the information about the "ebind-definitions". +-- | `ebindInfo` constructs the information about the "ebind-definitions". -------------------------------------------------------------------------------- ebindInfo :: F.SInfo a -> [(F.BindId, Sol.EbindSol)] ebindInfo si = group [((bid, x), cons cid) | (bid, cid, x) <- ebindDefs si] - where cons cid = const () <$> Misc.safeLookup "ebindInfo" cid cs + where cons cid = void (Misc.safeLookup "ebindInfo" cid cs) cs = F.cm si cmpByFst x y = fst ( fst x ) == fst ( fst y ) - group xs = (\ys -> ( (fst $ fst $ head ys) - , Sol.EbDef (snd <$> ys) (snd $ fst $ head ys))) + group xs = (\ys -> Bifunctor.second (Sol.EbDef (snd <$> ys)) (fst $ head ys)) <$> L.groupBy cmpByFst xs ebindDefs :: F.SInfo a -> [(F.BindId, F.SubcId, F.Symbol)] ebindDefs si = [ (bid, cid, x) | (cid, x) <- cDefs , bid <- maybeToList (M.lookup x ebSyms)] - where - ebSyms = ebindSyms si - cDefs = cstrDefs si + where + ebSyms = ebindSyms si + cDefs = cstrDefs si ebindSyms :: F.SInfo a -> M.HashMap F.Symbol F.BindId ebindSyms si = M.fromList [ (xi, bi) | bi <- ebinds si - , let (xi,_) = F.lookupBindEnv bi be ] + , let (xi,_,_) = F.lookupBindEnv bi be ] where - be = F.bs si - + be = F.bs si + cstrDefs :: F.SInfo a -> [(F.SubcId, F.Symbol)] cstrDefs si = [(cid, x) | (cid, c) <- M.toList (cm si) , x <- maybeToList (cstrDef be c) ] - where + where be = F.bs si -cstrDef :: F.BindEnv -> F.SimpC a -> Maybe F.Symbol -cstrDef be c - | Just (F.EVar x) <- e = Just x - | otherwise = Nothing - where - (v,_) = F.lookupBindEnv (cbind c) be - e = F.notracepp _msg $ F.isSingletonExpr v rhs - _msg = "cstrDef: " ++ show (stag c) ++ " crhs = " ++ F.showpp rhs - rhs = V.stripCasts (crhs c) - +cstrDef :: F.BindEnv a -> F.SimpC a -> Maybe F.Symbol +cstrDef be c + | Just (F.EVar x) <- e = Just x + | otherwise = Nothing + where + (v,_,_) = F.lookupBindEnv (cbind c) be + e = F.notracepp _msg $ F.isSingletonExpr v rhs + _msg = "cstrDef: " ++ show (stag c) ++ " crhs = " ++ F.showpp rhs + rhs = V.stripCasts (crhs c) diff --git a/src/Language/Fixpoint/Solver/Solve.hs b/src/Language/Fixpoint/Solver/Solve.hs --- a/src/Language/Fixpoint/Solver/Solve.hs +++ b/src/Language/Fixpoint/Solver/Solve.hs @@ -1,9 +1,10 @@ {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -------------------------------------------------------------------------------- -- | Solve a system of horn-clause constraints --------------------------------- -------------------------------------------------------------------------------- @@ -30,12 +31,17 @@ import Control.DeepSeq import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S --- import qualified Data.Maybe as Mb +-- import qualified Data.Maybe as Mb import qualified Data.List as L import Language.Fixpoint.Types (resStatus, FixResult(Unsafe)) import qualified Language.Fixpoint.Types.Config as C +import Language.Fixpoint.Solver.Interpreter (instInterpreter) import Language.Fixpoint.Solver.Instantiate (instantiate) +--import Debug.Trace (trace) +mytrace :: String -> a -> a +mytrace _ x = {- trace -} x + -------------------------------------------------------------------------------- solve :: (NFData a, F.Fixpoint a, Show a, F.Loc a) => Config -> F.SInfo a -> IO (F.Result (Integer, a)) -------------------------------------------------------------------------------- @@ -43,7 +49,7 @@ solve cfg fi = do whenLoud $ donePhase Misc.Loud "Worklist Initialize" vb <- getVerbosity - (res, stat) <- (if (Quiet == vb || gradual cfg) then id else withProgressFI sI) $ runSolverM cfg sI act + (res, stat) <- (if Quiet == vb || gradual cfg then id else withProgressFI sI) $ runSolverM cfg sI act when (solverStats cfg) $ printStats fi wkl stat -- print (numIter stat) return res @@ -59,7 +65,7 @@ -- | Progress Bar -------------------------------------------------------------------------------- withProgressFI :: SolverInfo a b -> IO b -> IO b -withProgressFI = withProgress . (+ 1) . fromIntegral . cNumScc . siDeps +withProgressFI = withProgress . (+ 1) . fromIntegral . cNumScc . siDeps -------------------------------------------------------------------------------- printStats :: F.SInfo a -> W.Worklist a -> Stats -> IO () @@ -79,9 +85,19 @@ siKvars :: F.SInfo a -> S.HashSet F.KVar siKvars = S.fromList . M.keys . F.ws +doInterpret :: (F.Loc a) => Config -> F.SInfo a -> [F.SubcId] -> SolveM a (F.SInfo a) +doInterpret cfg fi0 subcIds = do + fi <- liftIO $ instInterpreter cfg fi0 (Just subcIds) + modify $ update' fi + return fi + where + update' fi ss = ss{ssBinds = F.bs fi'} + where + fi' = (siQuery sI) {F.hoInfo = F.HOI (C.allowHO cfg) (C.allowHOqs cfg)} + sI = solverInfo cfg fi {-# SCC doPLE #-} -doPLE :: (F.Loc a) => Config -> F.SInfo a -> [F.SubcId] -> SolveM () +doPLE :: (F.Loc a) => Config -> F.SInfo a -> [F.SubcId] -> SolveM a () doPLE cfg fi0 subcIds = do fi <- liftIO $ instantiate cfg fi0 (Just subcIds) modify $ update' fi @@ -99,27 +115,40 @@ -> Sol.Solution -> S.HashSet F.KVar -> W.Worklist a - -> SolveM (F.Result (Integer, a), Stats) + -> SolveM a (F.Result (Integer, a), Stats) -------------------------------------------------------------------------------- solve_ cfg fi s0 ks wkl = do let s1 = {-# SCC "sol-init" #-} S.init cfg fi ks let s2 = mappend s0 s1 (s3, res0) <- sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do -- let s3 = solveEbinds fi s2 - s3 <- {- SCC "sol-refine" #-} refine bindingsInSmt s2 wkl - res0 <- {- SCC "sol-result" #-} result bindingsInSmt cfg wkl s3 + s3 <- {- SCC "sol-refine" -} refine bindingsInSmt s2 wkl + res0 <- {- SCC "sol-result" -} result bindingsInSmt cfg wkl s3 return (s3, res0) - res <- case resStatus res0 of - Unsafe _ bads | not (noLazyPLE cfg) && rewriteAxioms cfg -> do - doPLE cfg fi (map fst bads) + + (fi1, s4, res1) <- case resStatus res0 of {- first run the interpreter -} + Unsafe _ bads | not (noLazyPLE cfg) && rewriteAxioms cfg && interpreter cfg -> do + fi1 <- doInterpret cfg fi (map fst $ mytrace ("before the Interpreter " ++ show (length bads) ++ " constraints remain") bads) + (s4, res1) <- sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do + s4 <- {- SCC "sol-refine" -} refine bindingsInSmt s3 wkl + res1 <- {- SCC "sol-result" -} result bindingsInSmt cfg wkl s4 + return (s4, res1) + return (fi1, s4, res1) + _ -> return (fi, s3, mytrace "all checked before interpreter" res0) + + res2 <- case resStatus res1 of {- then run normal PLE on remaining unsolved constraints -} + Unsafe _ bads2 | not (noLazyPLE cfg) && rewriteAxioms cfg -> do + doPLE cfg fi1 (map fst $ mytrace ("before z3 PLE " ++ show (length bads2) ++ " constraints remain") bads2) sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do - s4 <- {- SCC "sol-refine" #-} refine bindingsInSmt s3 wkl - result bindingsInSmt cfg wkl s4 - _ -> return res0 + s5 <- {- SCC "sol-refine" -} refine bindingsInSmt s4 wkl + result bindingsInSmt cfg wkl s5 + _ -> return $ mytrace "all checked with interpreter" res1 + st <- stats - let res' = {- SCC "sol-tidy" #-} tidyResult res - return $!! (res', st) + let res3 = {- SCC "sol-tidy" -} tidyResult res2 + return $!! (res3, st) + -------------------------------------------------------------------------------- -- | tidyResult ensures we replace the temporary kVarArg names introduced to -- ensure uniqueness with the original names in the given WF constraints. @@ -143,7 +172,7 @@ => F.IBindEnv -> Sol.Solution -> W.Worklist a - -> SolveM Sol.Solution + -> SolveM a Sol.Solution -------------------------------------------------------------------------------- refine bindingsInSmt s w | Just (c, w', newScc, rnk) <- W.pop w = do @@ -168,7 +197,7 @@ -> Int -> Sol.Solution -> F.SimpC a - -> SolveM (Bool, Sol.Solution) + -> SolveM a (Bool, Sol.Solution) --------------------------------------------------------------------------- refineC bindingsInSmt _i s c | null rhs = return (False, s) @@ -207,7 +236,7 @@ -> Config -> W.Worklist a -> Sol.Solution - -> SolveM (F.Result (Integer, a)) + -> SolveM a (F.Result (Integer, a)) -------------------------------------------------------------------------------- result bindingsInSmt cfg wkl s = sendConcreteBindingsToSMT bindingsInSmt $ \bindingsInSmt2 -> do @@ -219,10 +248,10 @@ where ci c = (F.subcId c, F.sinfo c) -solResult :: Config -> Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr) +solResult :: Config -> Sol.Solution -> SolveM ann (M.HashMap F.KVar F.Expr) solResult cfg = minimizeResult cfg . Sol.result -solNonCutsResult :: Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr) +solNonCutsResult :: Sol.Solution -> SolveM ann (M.HashMap F.KVar F.Expr) solNonCutsResult s = do be <- getBinds return $ S.nonCutsResult be s @@ -233,7 +262,7 @@ -> Config -> W.Worklist a -> Sol.Solution - -> SolveM (F.FixResult (F.SimpC a)) + -> SolveM a (F.FixResult (F.SimpC a)) result_ bindingsInSmt cfg w s = do filtered <- filterM (isUnsat bindingsInSmt s) cs sts <- stats @@ -244,9 +273,9 @@ res sts cs' = F.Unsafe sts cs' isChecked :: Config -> [F.SimpC a] -> [F.SimpC a] -isChecked cfg cs = case checkCstr cfg of - [] -> cs - ids -> let s = S.fromList ids in +isChecked cfg cs = case checkCstr cfg of + [] -> cs + ids -> let s = S.fromList ids in [c | c <- cs, S.member (F.subcId c) s ] -------------------------------------------------------------------------------- @@ -260,13 +289,13 @@ -- see: tests/pos/min00.fq for an example. -------------------------------------------------------------------------------- minimizeResult :: Config -> M.HashMap F.KVar F.Expr - -> SolveM (M.HashMap F.KVar F.Expr) + -> SolveM ann (M.HashMap F.KVar F.Expr) -------------------------------------------------------------------------------- minimizeResult cfg s | minimalSol cfg = mapM minimizeConjuncts s | otherwise = return s -minimizeConjuncts :: F.Expr -> SolveM F.Expr +minimizeConjuncts :: F.Expr -> SolveM ann F.Expr minimizeConjuncts p = F.pAnd <$> go (F.conjuncts p) [] where go [] acc = return acc @@ -276,7 +305,7 @@ -------------------------------------------------------------------------------- isUnsat - :: (F.Loc a, NFData a) => F.IBindEnv -> Sol.Solution -> F.SimpC a -> SolveM Bool + :: (F.Loc a, NFData a) => F.IBindEnv -> Sol.Solution -> F.SimpC a -> SolveM a Bool -------------------------------------------------------------------------------- isUnsat bindingsInSmt s c = do -- lift $ printf "isUnsat %s" (show (F.subcId c)) @@ -304,9 +333,9 @@ | otherwise = errorstar $ "rhsPred on non-target: " ++ show (F.sid c) -------------------------------------------------------------------------------- -isValid :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM Bool +isValid :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM ann Bool -------------------------------------------------------------------------------- -isValid sp p q = (not . null) <$> filterValid sp p [(q, ())] +isValid sp p q = not . null <$> filterValid sp p [(q, ())] cstrSpan :: (F.Loc a) => F.SimpC a -> F.SrcSpan cstrSpan = F.srcSpan . F.sinfo @@ -355,7 +384,7 @@ = zip [1..] ((takei i `mappend` (takei j){F.bs = mempty}):rest) where takei i = snd (fis L.!! (i - 1)) - rest = snd <$> filter (\(k,_) -> (k /= i && k /= j)) fis + rest = snd <$> filter (\(k,_) -> k /= i && k /= j) fis partitionInfo :: (Int, F.SInfo a) -> String partitionInfo (i, fi) diff --git a/src/Language/Fixpoint/Solver/Stats.hs b/src/Language/Fixpoint/Solver/Stats.hs --- a/src/Language/Fixpoint/Solver/Stats.hs +++ b/src/Language/Fixpoint/Solver/Stats.hs @@ -14,11 +14,7 @@ import qualified Language.Fixpoint.Types.PrettyPrint as F import Data.Aeson -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - -data Stats = Stats +data Stats = Stats { numCstr :: !Int -- ^ # Horn Constraints , numIter :: !Int -- ^ # Refine Iterations , numBrkt :: !Int -- ^ # smtBracket calls (push/pop) @@ -39,7 +35,7 @@ ] instance Semigroup Stats where - s1 <> s2 = + s1 <> s2 = Stats { numCstr = numCstr s1 + numCstr s2 , numIter = numIter s1 + numIter s2 , numBrkt = numBrkt s1 + numBrkt s2 diff --git a/src/Language/Fixpoint/Solver/TrivialSort.hs b/src/Language/Fixpoint/Solver/TrivialSort.hs --- a/src/Language/Fixpoint/Solver/TrivialSort.hs +++ b/src/Language/Fixpoint/Solver/TrivialSort.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Solver.TrivialSort (nontrivsorts) where import GHC.Generics (Generic) @@ -84,10 +86,10 @@ updTISubC :: SubC a -> TrivInfo -> TrivInfo updTISubC c = updTI Lhs (slhs c) . updTI Rhs (srhs c) -updTIBinds :: BindEnv -> TrivInfo -> TrivInfo +updTIBinds :: BindEnv a -> TrivInfo -> TrivInfo updTIBinds be ti = foldl' (flip (updTI Lhs)) ti ts where - ts = [t | (_,_,t) <- bindEnvToList be] + ts = [t | (_, (_,t,_)) <- bindEnvToList be] -------------------------------------------------------------------- updTI :: Polarity -> SortedReft -> TrivInfo -> TrivInfo @@ -122,8 +124,8 @@ trivOrSingP p = trivP p || singP v p trivP :: Expr -> Bool -trivP (PKVar {}) = True -trivP p = isTautoPred p +trivP PKVar {} = True +trivP p = isTautoPred p singP :: Symbol -> Expr -> Bool singP v (PAtom Eq (EVar x) _) @@ -141,8 +143,8 @@ , bs = simplifyBindEnv tm $ bs fi } -simplifyBindEnv :: NonTrivSorts -> BindEnv -> BindEnv -simplifyBindEnv tm = mapBindEnv (\_ (x, sr) -> (x, simplifySortedReft tm sr)) +simplifyBindEnv :: NonTrivSorts -> BindEnv a -> BindEnv a +simplifyBindEnv tm = mapBindEnv (\_ (x, sr, a) -> (x, simplifySortedReft tm sr, a)) simplifyWfCs :: NonTrivSorts -> M.HashMap KVar (WfC a) -> M.HashMap KVar (WfC a) simplifyWfCs tm = M.filter (isNonTrivialSort tm . snd3 . wrft) diff --git a/src/Language/Fixpoint/Solver/UniqifyBinds.hs b/src/Language/Fixpoint/Solver/UniqifyBinds.hs --- a/src/Language/Fixpoint/Solver/UniqifyBinds.hs +++ b/src/Language/Fixpoint/Solver/UniqifyBinds.hs @@ -1,36 +1,37 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- This module makes it so no binds with different sorts have the same name. module Language.Fixpoint.Solver.UniqifyBinds (renameAll) where import Language.Fixpoint.Types import Language.Fixpoint.Solver.Sanitize (dropDeadSubsts) -import Language.Fixpoint.Misc (fst3, mlookup) +import Language.Fixpoint.Misc (fst3, mlookup, snd3) import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import qualified Data.List as L import Data.Foldable (foldl') -import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Maybe (catMaybes, mapMaybe, fromJust, isJust) import Data.Hashable (Hashable) import GHC.Generics (Generic) -import Control.Arrow (second) import Control.DeepSeq (NFData, ($!!)) -- import Debug.Trace (trace) -------------------------------------------------------------------------------- -renameAll :: SInfo a -> SInfo a +renameAll :: (NFData a) => SInfo a -> SInfo a -------------------------------------------------------------------------------- renameAll fi2 = fi6 where - fi6 = {- SCC "dropDead" #-} dropDeadSubsts fi5 - fi5 = {- SCC "dropUnused" #-} dropUnusedBinds fi4 - fi4 = {- SCC "renameBinds" #-} renameBinds fi3 $!! rnm - fi3 = {- SCC "renameVars" #-} renameVars fi2 rnm $!! idm - rnm = {- SCC "mkRenameMap" #-} mkRenameMap $!! bs fi2 - idm = {- SCC "mkIdMap" #-} mkIdMap fi2 + fi6 = {- SCC "dropDead" -} dropDeadSubsts fi5 + fi5 = {- SCC "dropUnused" -} dropUnusedBinds fi4 + fi4 = {- SCC "renameBinds" -} renameBinds fi3 $!! rnm + fi3 = {- SCC "renameVars" -} renameVars fi2 rnm $!! idm + rnm = {- SCC "mkRenameMap" -} mkRenameMap $!! bs fi2 + idm = {- SCC "mkIdMap" -} mkIdMap fi2 -------------------------------------------------------------------------------- @@ -71,19 +72,19 @@ -------------------------------------------------------------------------------- mkIdMap fi = M.foldlWithKey' (updateIdMap $ bs fi) M.empty $ cm fi -updateIdMap :: BindEnv -> IdMap -> Integer -> SimpC a -> IdMap +updateIdMap :: BindEnv a -> IdMap -> Integer -> SimpC a -> IdMap updateIdMap be m scId s = M.insertWith S.union (RI scId) refSet m' where ids = elemsIBindEnv (senv s) - nameMap = M.fromList [(fst $ lookupBindEnv i be, i) | i <- ids] + nameMap = M.fromList [(fst3 $ lookupBindEnv i be, i) | i <- ids] m' = foldl' (insertIdIdLinks be nameMap) m ids symSet = S.fromList $ syms $ crhs s refSet = namesToIds symSet nameMap -insertIdIdLinks :: BindEnv -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap +insertIdIdLinks :: BindEnv a -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap insertIdIdLinks be nameMap m i = M.insertWith S.union (RB i) refSet m where - sr = snd $ lookupBindEnv i be + sr = snd3 $ lookupBindEnv i be symSet = reftFreeVars $ sr_reft sr refSet = namesToIds symSet nameMap @@ -91,18 +92,19 @@ namesToIds xs m = S.fromList $ catMaybes [M.lookup x m | x <- S.toList xs] --TODO why any Nothings? -------------------------------------------------------------------------------- -mkRenameMap :: BindEnv -> RenameMap +mkRenameMap :: BindEnv a -> RenameMap -------------------------------------------------------------------------------- mkRenameMap be = foldl' (addId be) M.empty ids where - ids = fst3 <$> bindEnvToList be + ids = fst <$> bindEnvToList be -addId :: BindEnv -> RenameMap -> BindId -> RenameMap +addId :: BindEnv a -> RenameMap -> BindId -> RenameMap addId be m i | M.member sym m = addDupId m sym t i | otherwise = M.insert sym [(t, Nothing)] m where - (sym, t) = second sr_sort $ lookupBindEnv i be + t = sr_sort sr + (sym, sr, _) = lookupBindEnv i be addDupId :: RenameMap -> Symbol -> Sort -> BindId -> RenameMap addDupId m sym t i @@ -122,8 +124,9 @@ updateRef :: RenameMap -> SInfo a -> Ref -> S.HashSet BindId -> SInfo a updateRef rnMap fi rf bset = applySub (mkSubst subs) fi rf where - symTList = [second sr_sort $ lookupBindEnv i $ bs fi | i <- S.toList bset] - subs = catMaybes $ mkSubUsing rnMap <$> symTList + symTList = [ (sym, sr_sort sr) | i <- S.toList bset, let (sym, sr, _) = lookupBindEnv i bEnv] + bEnv = bs fi + subs = mapMaybe (mkSubUsing rnMap) symTList mkSubUsing :: RenameMap -> (Symbol, Sort) -> Maybe (Symbol, Expr) mkSubUsing m (sym, t) = do @@ -144,12 +147,12 @@ -------------------------------------------------------------------------------- renameBinds fi m = fi { bs = bindEnvFromList $ renameBind m <$> beList } where - beList = bindEnvToList $ bs fi + beList = bindEnvToList (bs fi) -renameBind :: RenameMap -> (BindId, Symbol, SortedReft) -> (BindId, Symbol, SortedReft) -renameBind m (i, sym, sr) - | Just newSym <- mnewSym = (i, newSym, sr) - | otherwise = (i, sym, sr) +renameBind :: RenameMap -> (BindId, (Symbol, SortedReft, a)) -> (BindId, (Symbol, SortedReft, a)) +renameBind m (i, (sym, sr, ann)) + | Just newSym <- mnewSym = (i, (newSym, sr, ann)) + | otherwise = (i, (sym, sr, ann)) where t = sr_sort sr mnewSym = fromJust $ L.lookup t $ mlookup m sym diff --git a/src/Language/Fixpoint/Solver/UniqifyKVars.hs b/src/Language/Fixpoint/Solver/UniqifyKVars.hs --- a/src/Language/Fixpoint/Solver/UniqifyKVars.hs +++ b/src/Language/Fixpoint/Solver/UniqifyKVars.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + {- | This module creates new bindings for each argument of each kvar. It also makes sure that all arguments to each kvar are explicit. @@ -75,31 +77,32 @@ where w' = updateWfCExpr (subst su) w'' w'' = w { wenv = insertsIBindEnv newIds mempty, wrft = (v', t, k) } - (_, fi'') = newTopBind v' (trueSortedReft t) fi' - (fi', newIds) = foldl' (accumBindsIfValid k) (fi, []) (elemsIBindEnv $ wenv w) + (_, fi'') = newTopBind v' (trueSortedReft t) a fi' + (fi', newIds) = foldl' (accumBindsIfValid k a) (fi, []) (elemsIBindEnv $ wenv w) (v, t, k) = wrft w v' = kArgSymbol v (kv k) su = mkSubst ((v, EVar v'):[(x, eVar $ kArgSymbol x (kv k)) | x <- kvarDomain fi k]) + a = winfo w -accumBindsIfValid :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId]) -accumBindsIfValid k (fi, ids) i = if renamable then accumBinds k (fi, ids) i else (fi, i : ids) +accumBindsIfValid :: KVar -> a -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId]) +accumBindsIfValid k a (fi, ids) i = if renamable then accumBinds k a (fi, ids) i else (fi, i : ids) where - (_, sr) = lookupBindEnv i (bs fi) + (_, sr, _) = lookupBindEnv i (bs fi) renamable = isValidInRefinements (sr_sort sr) -accumBinds :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId]) -accumBinds k (fi, ids) i = (fi', i' : ids) +accumBinds :: KVar -> a -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId]) +accumBinds k a (fi, ids) i = (fi', i' : ids) where - (oldSym, sr) = lookupBindEnv i (bs fi) + (oldSym, sr,_) = lookupBindEnv i (bs fi) newSym = {- tracepp "kArgSymbol" $ -} kArgSymbol oldSym (kv k) - (i', fi') = newTopBind newSym sr fi + (i', fi') = newTopBind newSym sr a fi -- | `newTopBind` ignores the actual refinements as they are not relevant -- in the kvar parameters (as suggested by BLC.) -newTopBind :: Symbol -> SortedReft -> SInfo a -> (BindId, SInfo a) -newTopBind x sr fi = (i', fi {bs = be'}) +newTopBind :: Symbol -> SortedReft -> a -> SInfo a -> (BindId, SInfo a) +newTopBind x sr a fi = (i', fi {bs = be'}) where - (i', be') = insertBindEnv x (top sr) (bs fi) + (i', be') = insertBindEnv x (top sr) a (bs fi) -------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/Worklist.hs b/src/Language/Fixpoint/Solver/Worklist.hs --- a/src/Language/Fixpoint/Solver/Worklist.hs +++ b/src/Language/Fixpoint/Solver/Worklist.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} module Language.Fixpoint.Solver.Worklist ( -- * Worklist type is opaque diff --git a/src/Language/Fixpoint/SortCheck.hs b/src/Language/Fixpoint/SortCheck.hs --- a/src/Language/Fixpoint/SortCheck.hs +++ b/src/Language/Fixpoint/SortCheck.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-} @@ -11,6 +9,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module has the functions that perform sort-checking, and related -- operations on Fixpoint expressions and predicates. @@ -31,7 +31,7 @@ , sortExpr , checkSortExpr , exprSort - , exprSort_maybe + , exprSortMaybe -- * Unify , unifyFast @@ -50,7 +50,14 @@ -- * Sort-Directed Transformations , Elaborate (..) , applySorts - , unElab, unElabSortedReft, unApplyAt + , elabApply + , elabExpr + , elabNumeric + , unApply + , unElab + , unElabSortedReft + , unApplySortedReft + , unApplyAt , toInt -- * Predicates on Sorts @@ -70,14 +77,10 @@ import Data.IORef import qualified Data.List as L import Data.Maybe (mapMaybe, fromMaybe, catMaybes, isJust) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Language.Fixpoint.Types.PrettyPrint import Language.Fixpoint.Misc -import Language.Fixpoint.Types hiding (subst) +import Language.Fixpoint.Types hiding (subst, GInfo(..), senv) import qualified Language.Fixpoint.Types.Visitor as Vis import qualified Language.Fixpoint.Smt.Theories as Thy import Text.PrettyPrint.HughesPJ.Compat @@ -124,11 +127,12 @@ instance (Loc a) => Elaborate (SInfo a) where elaborate x senv si = si - { cm = elaborate x senv <$> cm si - , bs = elaborate x senv $ bs si - , asserts = elaborate x senv <$> asserts si + { F.cm = elaborate x senv <$> F.cm si + , F.bs = elaborate x senv $ F.bs si + , F.asserts = elaborate x senv <$> F.asserts si } + instance (Elaborate e) => (Elaborate (Triggered e)) where elaborate x env t = fmap (elaborate x env) t @@ -148,27 +152,27 @@ instance Elaborate AxiomEnv where elaborate msg env ae = ae - { aenvEqs = elaborate msg env (aenvEqs ae) - -- MISSING SORTS OOPS, aenvSimpl = elaborate msg env (aenvSimpl ae) + { aenvEqs = elaborate msg env (aenvEqs ae) + -- MISSING SORTS OOPS, aenvSimpl = elaborate msg env (aenvSimpl ae) } -instance Elaborate Rewrite where - elaborate msg env rw = rw { smBody = skipElabExpr msg env' (smBody rw) } - where +instance Elaborate Rewrite where + elaborate msg env rw = rw { smBody = skipElabExpr msg env' (smBody rw) } + where env' = insertsSymEnv env undefined -instance Elaborate Equation where - elaborate msg env eq = eq { eqBody = skipElabExpr msg env' (eqBody eq) } +instance Elaborate Equation where + elaborate msg env eq = eq { eqBody = skipElabExpr msg env' (eqBody eq) } where - env' = insertsSymEnv env (eqArgs eq) + env' = insertsSymEnv env (eqArgs eq) instance Elaborate Expr where elaborate msg env = elabNumeric . elabApply env . elabExpr msg env -skipElabExpr :: Located String -> SymEnv -> Expr -> Expr -skipElabExpr msg env e = case elabExprE msg env e of - Left _ -> e +skipElabExpr :: Located String -> SymEnv -> Expr -> Expr +skipElabExpr msg env e = case elabExprE msg env e of + Left _ -> e Right e' -> elabNumeric . elabApply env $ e' instance Elaborate (Symbol, Sort) where @@ -197,11 +201,10 @@ e' = elaborate x env' e env' = insertSymEnv v s env -instance Elaborate BindEnv where - elaborate z env = mapBindEnv (\i (x, sr) -> (x, elaborate (z' i x sr) env sr)) +instance (Loc a) => Elaborate (BindEnv a) where + elaborate msg env = mapBindEnv (\i (x, sr, l) -> (x, elaborate (msg' l i x sr) env sr, l)) where - z' i x sr = z { val = (val z) ++ msg i x sr } - msg i x sr = unwords [" elabBE", show i, show x, show sr] + msg' l i x sr = atLoc l (val msg ++ unwords [" elabBE", show i, show x, show sr]) instance (Loc a) => Elaborate (SimpC a) where elaborate msg env c = c {_crhs = elaborate msg' env (_crhs c) } @@ -210,20 +213,20 @@ -- | 'elabExpr' adds "casts" to decorate polymorphic instantiation sites. -------------------------------------------------------------------------------- elabExpr :: Located String -> SymEnv -> Expr -> Expr -elabExpr msg env e = case elabExprE msg env e of - Left ex -> die ex - Right e' -> F.notracepp ("elabExp " ++ showpp e) e' +elabExpr msg env e = case elabExprE msg env e of + Left ex -> die ex + Right e' -> F.notracepp ("elabExp " ++ showpp e) e' elabExprE :: Located String -> SymEnv -> Expr -> Either Error Expr -elabExprE msg env e = - case runCM0 (srcSpan msg) (elab (env, f) e) of - Left (ChError f) -> - let e = f () - in Left $ err (srcSpan e) (d (val e)) +elabExprE msg env e = + case runCM0 (srcSpan msg) (elab (env, envLookup) e) of + Left (ChError f') -> + let e' = f' () + in Left $ err (srcSpan e') (d (val e')) Right s -> Right (fst s) where sEnv = seSort env - f = (`lookupSEnvWithDistance` sEnv) + envLookup = (`lookupSEnvWithDistance` sEnv) d m = vcat [ "elaborate" <+> text (val msg) <+> "failed on:" , nest 4 (pprint e) , "with error" @@ -259,10 +262,10 @@ step (ELam b e) = ELam b (go e) step (ECoerc a t e) = ECoerc a t (go e) step (PGrad k su i e) = PGrad k su i (go e) - step e@(PKVar {}) = e - step e@(ESym {}) = e - step e@(ECon {}) = e - step e@(EVar {}) = e + step e@PKVar{} = e + step e@ESym{} = e + step e@ECon{} = e + step e@EVar{} = e -- ETApp, ETAbs, PAll, PExist step e = error $ "TODO elabApply: " ++ showpp e @@ -271,7 +274,7 @@ -------------------------------------------------------------------------------- sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort sortExpr l γ e = case runCM0 l (checkExpr f e) of - Left (ChError f) -> die $ err l (d (val (f ()))) + Left (ChError f') -> die $ err l (d (val (f' ()))) Right s -> s where f = (`lookupSEnvWithDistance` γ) @@ -293,7 +296,7 @@ Nothing -> Alts [] subEnv :: (Subable e) => SEnv a -> e -> SEnv a -subEnv g e = intersectWithSEnv (\t _ -> t) g g' +subEnv g e = intersectWithSEnv const g g' where g' = fromListSEnv $ (, ()) <$> syms e @@ -321,9 +324,9 @@ -------------------------------------------------------------------------------- -mkSearchEnv :: SEnv a -> Symbol -> SESearch a +mkSearchEnv :: SEnv a -> Symbol -> SESearch a -------------------------------------------------------------------------------- -mkSearchEnv env x = lookupSEnvWithDistance x env +mkSearchEnv env x = lookupSEnvWithDistance x env -- withError :: CheckM a -> ChError -> CheckM a -- act `withError` e' = act `catchError` (\e -> throwError (atLoc e (val e ++ "\n because\n" ++ val e'))) @@ -335,21 +338,26 @@ (\(ChError f) -> throwIO $ ChError $ \_ -> let e = f () - in (atLoc e (val e ++ "\n because\n" ++ msg)) + in atLoc e (val e ++ "\n because\n" ++ msg) ) +-- XXX: Why start at 42? +{-# NOINLINE varCounterRef #-} +varCounterRef :: IORef Int +varCounterRef = unsafePerformIO $ newIORef 42 + +-- XXX: Since 'varCounterRef' was made global, this +-- function is not referentially transparent. +-- Each evaluation of the function starts with a different +-- value of counter. runCM0 :: SrcSpan -> CheckM a -> Either ChError a runCM0 sp act = unsafePerformIO $ do - rn <- newIORef 42 - try (runReaderT act (ChS rn sp)) + try (runReaderT act (ChS varCounterRef sp)) fresh :: CheckM Int fresh = do rn <- asks chCount - liftIO $ do - n <- readIORef rn - writeIORef rn (n + 1) - return n + liftIO $ atomicModifyIORef' rn $ \n -> (n+1, n) -------------------------------------------------------------------------------- -- | Checking Refinements ------------------------------------------------------ @@ -362,7 +370,7 @@ Reft (v,_) = sr_reft sr checkSortedReftFull :: Checkable a => SrcSpan -> SEnv SortedReft -> a -> Maybe Doc -checkSortedReftFull sp γ t = +checkSortedReftFull sp γ t = case runCM0 sp (check γ' t) of Left (ChError f) -> Just (text (val (f ()))) Right _ -> Nothing @@ -370,7 +378,7 @@ γ' = sr_sort <$> γ checkSortFull :: Checkable a => SrcSpan -> SEnv SortedReft -> Sort -> a -> Maybe Doc -checkSortFull sp γ s t = +checkSortFull sp γ s t = case runCM0 sp (checkSort γ' s t) of Left (ChError f) -> Just (text (val (f ()))) Right _ -> Nothing @@ -378,25 +386,25 @@ γ' = sr_sort <$> γ checkSorted :: Checkable a => SrcSpan -> SEnv Sort -> a -> Maybe Doc -checkSorted sp γ t = +checkSorted sp γ t = case runCM0 sp (check γ t) of Left (ChError f) -> Just (text (val (f ()))) Right _ -> Nothing pruneUnsortedReft :: SEnv Sort -> Templates -> SortedReft -> SortedReft -pruneUnsortedReft _ t r - | isEmptyTemplates t - = r +pruneUnsortedReft _ t r + | isEmptyTemplates t + = r pruneUnsortedReft γ t (RR s (Reft (v, p))) - | isAnyTemplates t - -- this is the old code that checks everything + | isAnyTemplates t + -- this is the old code that checks everything = RR s (Reft (v, tx filterAny p)) | otherwise = RR s (Reft (v, tx (filter filterWithTemplate) p)) where filterAny = mapMaybe (checkPred' f) filterWithTemplate e = not (matchesTemplates t e) || isJust (checkPred' f e) - tx f = pAnd . f . conjuncts + tx f' = pAnd . f' . conjuncts f = (`lookupSEnvWithDistance` γ') γ' = insertSEnv v s γ -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t @@ -447,13 +455,13 @@ checkExpr f (PAnd ps) = mapM_ (checkPred f) ps >> return boolSort checkExpr f (POr ps) = mapM_ (checkPred f) ps >> return boolSort checkExpr f (PAtom r e e') = checkRel f r e e' >> return boolSort -checkExpr _ (PKVar {}) = return boolSort +checkExpr _ PKVar{} = return boolSort checkExpr f (PGrad _ _ _ e) = checkPred f e >> return boolSort checkExpr f (PAll bs e ) = checkExpr (addEnv f bs) e checkExpr f (PExist bs e) = checkExpr (addEnv f bs) e checkExpr f (ELam (x,t) e) = FFunc t <$> checkExpr (addEnv f [(x,t)]) e -checkExpr f (ECoerc s t e) = checkExpr f (ECst e s) >> return t +checkExpr f (ECoerc s t e) = checkExpr f (ECst e s) >> return t checkExpr _ (ETApp _ _) = error "SortCheck.checkExpr: TODO: implement ETApp" checkExpr _ (ETAbs _ _) = error "SortCheck.checkExpr: TODO: implement ETAbs" @@ -473,17 +481,17 @@ (e1', s1) <- elab f e1 (e2', s2) <- elab f e2 s <- checkOpTy g e s1 s2 - return (EBin o (ECst e1' s1) (ECst e2' s2), s) + return (EBin o (eCst e1' s1) (eCst e2' s2), s) elab f (EApp e1@(EApp _ _) e2) = do (e1', _, e2', s2, s) <- notracepp "ELAB-EAPP" <$> elabEApp f e1 e2 - let e = eAppC s e1' (ECst e2' s2) + let e = eAppC s e1' (eCst e2' s2) let θ = unifyExpr (snd f) e return (applyExpr θ e, maybe s (`apply` s) θ) elab f (EApp e1 e2) = do (e1', s1, e2', s2, s) <- elabEApp f e1 e2 - let e = eAppC s (ECst e1' s1) (ECst e2' s2) + let e = eAppC s (eCst e1' s1) (eCst e2' s2) let θ = unifyExpr (snd f) e return (applyExpr θ e, maybe s (`apply` s) θ) @@ -503,7 +511,7 @@ return (e, boolSort) elab f (PGrad k su i e) = - ((, boolSort) . PGrad k su i . fst) <$> elab f e + (, boolSort) . PGrad k su i . fst <$> elab f e elab (_, f) e@(EVar x) = (e,) <$> checkSym f x @@ -514,22 +522,22 @@ elab f@(_,g) (ECst (EIte p e1 e2) t) = do (p', _) <- elab f p - (e1', s1) <- elab f (ECst e1 t) - (e2', s2) <- elab f (ECst e2 t) + (e1', s1) <- elab f (eCst e1 t) + (e2', s2) <- elab f (eCst e2 t) s <- checkIteTy g p e1' e2' s1 s2 - return (EIte p' (cast e1' s) (cast e2' s), t) + return (EIte p' (eCst e1' s) (eCst e2' s), t) elab f@(_,g) (EIte p e1 e2) = do - t <- getIte g e1 e2 + t <- getIte g e1 e2 (p', _) <- elab f p - (e1', s1) <- elab f (ECst e1 t) - (e2', s2) <- elab f (ECst e2 t) + (e1', s1) <- elab f (eCst e1 t) + (e2', s2) <- elab f (eCst e2 t) s <- checkIteTy g p e1' e2' s1 s2 - return (EIte p' (cast e1' s) (cast e2' s), s) + return (EIte p' (eCst e1' s) (eCst e2' s), s) elab f (ECst e t) = do (e', _) <- elab f e - return (ECst e' t, t) + return (eCst e' t, t) elab f (PNot p) = do (e', _) <- elab f p @@ -556,7 +564,7 @@ elab f@(_,g) e@(PAtom eq e1 e2) | eq == Eq || eq == Ne = do t1 <- checkExpr g e1 t2 <- checkExpr g e2 - (t1',t2') <- unite g e t1 t2 `withError` (errElabExpr e) + (t1',t2') <- unite g e t1 t2 `withError` errElabExpr e e1' <- elabAs f t1' e1 e2' <- elabAs f t2' e2 e1'' <- eCstAtom f e1' t1' @@ -587,7 +595,7 @@ elab f (ELam (x,t) e) = do (e', s) <- elab (elabAddEnv f [(x, t)]) e let t' = elaborate "ELam Arg" mempty t - return (ELam (x, t') (ECst e' s), FFunc t s) + return (ELam (x, t') (eCst e' s), FFunc t s) elab f (ECoerc s t e) = do (e', _) <- elab f e @@ -601,14 +609,14 @@ -- | 'eCstAtom' is to support tests like `tests/pos/undef00.fq` eCstAtom :: ElabEnv -> Expr -> Sort -> CheckM Expr -eCstAtom f@(sym,g) (EVar x) t +eCstAtom f@(sym,g) (EVar x) t | Found s <- g x - , isUndef s + , isUndef s , not (isInt sym t) = (`ECst` t) <$> elabAs f t (EApp (eVar tyCastName) (eVar x)) eCstAtom _ e t = return (ECst e t) isUndef :: Sort -> Bool -isUndef s = case bkAbs s of +isUndef s = case bkAbs s of (is, FVar j) -> j `elem` is _ -> False @@ -616,16 +624,12 @@ elabAddEnv :: Eq a => (t, a -> SESearch b) -> [(a, b)] -> (t, a -> SESearch b) elabAddEnv (g, f) bs = (g, addEnv f bs) -cast :: Expr -> Sort -> Expr -cast (ECst e _) t = ECst e t -cast e t = ECst e t - elabAs :: ElabEnv -> Sort -> Expr -> CheckM Expr elabAs f t e = notracepp _msg <$> go e where _msg = "elabAs: t = " ++ showpp t ++ " e = " ++ showpp e go (EApp e1 e2) = elabAppAs f t e1 e2 - go e = fst <$> elab f e + go e' = fst <$> elab f e' -- DUPLICATION with `checkApp'` elabAppAs :: ElabEnv -> Sort -> Expr -> Expr -> CheckM Expr @@ -653,20 +657,21 @@ let e = Just (EApp e1 e2) (sIn, sOut, su) <- checkFunSort s1 su' <- unify1 f e su sIn s2 - return $ (applyExpr (Just su') e1, applyExpr (Just su') e2, apply su' s1, apply su' s2, apply su' sOut) + return (applyExpr (Just su') e1, applyExpr (Just su') e2, apply su' s1, apply su' s2, apply su' sOut) -------------------------------------------------------------------------------- -- | defuncEApp monomorphizes function applications. -------------------------------------------------------------------------------- defuncEApp :: SymEnv -> Expr -> [(Expr, Sort)] -> Expr -defuncEApp env e es = L.foldl' makeApplication e' es' +defuncEApp _env e [] = e +defuncEApp env e es = eCst (L.foldl' makeApplication e' es') (snd $ last es) where (e', es') = takeArgs (seTheory env) e es takeArgs :: SEnv TheorySymbol -> Expr -> [(Expr, a)] -> (Expr, [(Expr, a)]) takeArgs env e es = - case Thy.isSmt2App env (Vis.stripCasts e) of + case Thy.isSmt2App env e of Just n -> let (es1, es2) = splitAt n es in (eApps e (fst <$> es1), es2) Nothing -> (e, es) @@ -709,21 +714,24 @@ unElabSortedReft :: SortedReft -> SortedReft unElabSortedReft sr = sr { sr_reft = mapPredReft unElab (sr_reft sr) } +unApplySortedReft :: SortedReft -> SortedReft +unApplySortedReft sr = sr { sr_reft = mapPredReft unApply (sr_reft sr) } + unApply :: Expr -> Expr -unApply = Vis.trans (Vis.defaultVisitor { Vis.txExpr = const go }) () () +unApply = Vis.mapExprOnExpr go where go (ECst (EApp (EApp f e1) e2) _) | Just _ <- unApplyAt f = EApp e1 e2 - go (ELam (x,s) e) = ELam (x, Vis.mapSort go' s) e + go (ELam (x,s) e) = ELam (x, Vis.mapSort go' s) e go e = e - go' (FApp (FApp fs t1) t2) | fs == funcSort - = FFunc t1 t2 - go' t = t + go' (FApp (FApp fs t1) t2) | fs == funcSort + = FFunc t1 t2 + go' t = t unApplyAt :: Expr -> Maybe Sort -unApplyAt (ECst (EVar f) t@(FFunc {})) +unApplyAt (ECst (EVar f) t@FFunc{}) | f == applyName = Just t unApplyAt _ = Nothing @@ -773,20 +781,20 @@ proj :: Field a -> a -> a proj fld x = case fld of FInt -> 1 + x - FBool -> not b + FBool -> not b ``` ## The Problem The problem is you cannot encode the body of `proj` as a well-sorted refinement: - + ```haskell if is$FInt fld then (1 + (coerce (a ~ Int) x)) else (not (coerce (a ~ Bool) x)) ``` -The catch is that `x` is being used BOTH as `Int` and as `Bool` +The catch is that `x` is being used BOTH as `Int` and as `Bool` which is not supported in SMTLIB. ## Approach: Uninterpreted Functions @@ -799,7 +807,7 @@ else (not (coerce@(a -> bool) x)) ``` -where we define, extra constants in the style of `apply` +where we define, extra constants in the style of `apply` ```haskell constant coerce@(a -> int ) :: a -> int @@ -853,19 +861,19 @@ | f == applyName = [t] go _ (ECoerc t1 t2 _) -- get types needed for [NOTE:coerce-apply] - = [FFunc t1 t2] + = [FFunc t1 t2] go _ _ = [] -------------------------------------------------------------------------------- -- | Expressions sort --------------------------------------------------------- -------------------------------------------------------------------------------- exprSort :: String -> Expr -> Sort -exprSort msg e = fromMaybe (panic err) (exprSort_maybe e) +exprSort msg e = fromMaybe (panic err') (exprSortMaybe e) where - err = printf "exprSort [%s] on unexpected expression %s" msg (show e) + err' = printf "exprSort [%s] on unexpected expression %s" msg (show e) -exprSort_maybe :: Expr -> Maybe Sort -exprSort_maybe = go +exprSortMaybe :: Expr -> Maybe Sort +exprSortMaybe = go where go (ECst _ s) = Just s go (ELam (_, sx) e) = FFunc sx <$> go e @@ -883,11 +891,11 @@ su <- unifys f (Just e) [t1] [t2] return (apply su t1, apply su t2) -throwErrorAt :: String -> CheckM a -throwErrorAt ~err = do -- Lazy pattern needed because we use LANGUAGE Strict in this module +throwErrorAt :: String -> CheckM a +throwErrorAt ~err' = do -- Lazy pattern needed because we use LANGUAGE Strict in this module -- See Note [Lazy error messages] sp <- asks chSpan - liftIO $ throwIO (ChError (\_ -> atLoc sp err)) + liftIO $ throwIO (ChError (\_ -> atLoc sp err')) -- Note [Lazy error messages] -- @@ -909,15 +917,15 @@ t2 <- checkExpr f e2 checkIteTy f p e1 e2 t1 t2 -getIte :: Env -> Expr -> Expr -> CheckM Sort -getIte f e1 e2 = do - t1 <- checkExpr f e1 - t2 <- checkExpr f e2 +getIte :: Env -> Expr -> Expr -> CheckM Sort +getIte f e1 e2 = do + t1 <- checkExpr f e1 + t2 <- checkExpr f e2 (`apply` t1) <$> unifys f Nothing [t1] [t2] checkIteTy :: Env -> Expr -> Expr -> Expr -> Sort -> Sort -> CheckM Sort checkIteTy f p e1 e2 t1 t2 - = ((`apply` t1) <$> unifys f e' [t1] [t2]) `withError` (errIte e1 e2 t1 t2) + = ((`apply` t1) <$> unifys f e' [t1] [t2]) `withError` errIte e1 e2 t1 t2 where e' = Just (EIte p e1 e2) @@ -927,7 +935,7 @@ = checkApp f (Just t) g e checkCst f t e = do t' <- checkExpr f e - ((`apply` t) <$> unifys f (Just e) [t] [t']) `withError` (errCast e t' t) + ((`apply` t) <$> unifys f (Just e) [t] [t']) `withError` errCast e t' t checkApp :: Env -> Maybe Sort -> Expr -> Expr -> CheckM Sort checkApp f to g es @@ -1010,13 +1018,13 @@ checkNumeric _ s = unless (isNumeric s) (throwErrorAt $ errNonNumeric s) -checkEqConstr :: Env -> Maybe Expr -> TVSubst -> Symbol -> Sort -> CheckM TVSubst +checkEqConstr :: Env -> Maybe Expr -> TVSubst -> Symbol -> Sort -> CheckM TVSubst checkEqConstr _ _ θ a (FObj b) | a == b = return θ -checkEqConstr f e θ a t = do +checkEqConstr f e θ a t = case f a of - Found tA -> unify1 f e θ tA t + Found tA -> unify1 f e θ tA t _ -> throwErrorAt $ errUnifyMsg (Just "ceq2") e (FObj a) t -------------------------------------------------------------------------------- @@ -1035,7 +1043,7 @@ checkRel f Eq e1 e2 = do t1 <- checkExpr f e1 t2 <- checkExpr f e2 - su <- (unifys f (Just e) [t1] [t2]) `withError` (errRel e t1 t2) + su <- unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2 _ <- checkExprAs f (apply su t1) e1 _ <- checkExprAs f (apply su t2) e2 checkRelTy f e Eq t1 t2 @@ -1050,23 +1058,23 @@ checkRelTy :: Env -> Expr -> Brel -> Sort -> Sort -> CheckM () checkRelTy _ e Ueq s1 s2 = checkURel e s1 s2 -checkRelTy _ e Une s1 s2 = checkURel e s1 s2 +checkRelTy _ e Une s1 s2 = checkURel e s1 s2 checkRelTy f _ _ s1@(FObj l) s2@(FObj l') | l /= l' - = (checkNumeric f s1 >> checkNumeric f s2) `withError` (errNonNumerics l l') + = (checkNumeric f s1 >> checkNumeric f s2) `withError` errNonNumerics l l' checkRelTy _ _ _ FReal FReal = return () checkRelTy _ _ _ FInt FReal = return () checkRelTy _ _ _ FReal FInt = return () -checkRelTy f _ _ FInt s2 = checkNumeric f s2 `withError` (errNonNumeric s2) -checkRelTy f _ _ s1 FInt = checkNumeric f s1 `withError` (errNonNumeric s1) -checkRelTy f _ _ FReal s2 = checkFractional f s2 `withError` (errNonFractional s2) -checkRelTy f _ _ s1 FReal = checkFractional f s1 `withError` (errNonFractional s1) -checkRelTy f e Eq t1 t2 = void (unifys f (Just e) [t1] [t2] `withError` (errRel e t1 t2)) -checkRelTy f e Ne t1 t2 = void (unifys f (Just e) [t1] [t2] `withError` (errRel e t1 t2)) +checkRelTy f _ _ FInt s2 = checkNumeric f s2 `withError` errNonNumeric s2 +checkRelTy f _ _ s1 FInt = checkNumeric f s1 `withError` errNonNumeric s1 +checkRelTy f _ _ FReal s2 = checkFractional f s2 `withError` errNonFractional s2 +checkRelTy f _ _ s1 FReal = checkFractional f s1 `withError` errNonFractional s1 +checkRelTy f e Eq t1 t2 = void (unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2) +checkRelTy f e Ne t1 t2 = void (unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2) checkRelTy _ e _ t1 t2 = unless (t1 == t2) (throwErrorAt $ errRel e t1 t2) checkURel :: Expr -> Sort -> Sort -> CheckM () checkURel e s1 s2 = unless (b1 == b2) (throwErrorAt $ errRel e s1 s2) - where + where b1 = s1 == boolSort b2 = s2 == boolSort @@ -1088,8 +1096,8 @@ unifyExprApp :: Env -> Expr -> Expr -> Maybe TVSubst unifyExprApp f e1 e2 = do - t1 <- getArg $ exprSort_maybe e1 - t2 <- exprSort_maybe e2 + t1 <- getArg $ exprSortMaybe e1 + t2 <- exprSortMaybe e2 unify f (Just $ EApp e1 e2) t1 t2 where getArg (Just (FFunc t1 _)) = Just t1 @@ -1110,21 +1118,21 @@ -------------------------------------------------------------------------------- unifyTo1 :: Env -> [Sort] -> Maybe Sort -------------------------------------------------------------------------------- -unifyTo1 f ts +unifyTo1 f ts = case runCM0 dummySpan (unifyTo1M f ts) of Left _ -> Nothing - Right t -> Just t + Right t -> Just t -------------------------------------------------------------------------------- -unifyTo1M :: Env -> [Sort] -> CheckM Sort +unifyTo1M :: Env -> [Sort] -> CheckM Sort -------------------------------------------------------------------------------- unifyTo1M _ [] = panic "unifyTo1: empty list" unifyTo1M f (t0:ts) = snd <$> foldM step (emptySubst, t0) ts - where + where step :: (TVSubst, Sort) -> Sort -> CheckM (TVSubst, Sort) - step (su, t) t' = do - su' <- unify1 f Nothing su t t' + step (su, t) t' = do + su' <- unify1 f Nothing su t t' return (su', apply su' t) @@ -1133,7 +1141,7 @@ -------------------------------------------------------------------------------- unifySorts = unifyFast False emptyEnv where - emptyEnv = const $ die $ err dummySpan "SortChecl: lookup in Empty Env " + emptyEnv x = die $ err dummySpan $ "SortCheck: lookup in Empty Env: " <> pprint x -------------------------------------------------------------------------------- @@ -1148,20 +1156,20 @@ {- eqFast :: Sort -> Sort -> Bool -eqFast = go - where +eqFast = go + where go FAbs {} _ = False - go (FFunc s1 s2) t = case t of + go (FFunc s1 s2) t = case t of FFunc t1 t2 -> go s1 t1 && go s2 t2 _ -> False - go (FApp s1 s2) t = case t of + go (FApp s1 s2) t = case t of FApp t1 t2 -> go s1 t1 && go s2 t2 _ -> False - go (FTC s1) t = case t of + go (FTC s1) t = case t of FTC t1 -> s1 == t1 _ -> False - + go FInt FInt = True go FReal FReal = True go FNum FNum = True @@ -1169,7 +1177,7 @@ go (FVar i1) (FVar i2) = i1 == i2 go _ _ = False - -} + -} -------------------------------------------------------------------------------- unifys :: HasCallStack => Env -> Maybe Expr -> [Sort] -> [Sort] -> CheckM TVSubst -------------------------------------------------------------------------------- @@ -1190,7 +1198,7 @@ unify1 _ _ !θ (FTC !l1) (FTC !l2) | isListTC l1 && isListTC l2 = return θ -unify1 f e !θ !t1@(FAbs _ _) !t2 = do +unify1 f e !θ t1@(FAbs _ _) !t2 = do !t1' <- instantiate t1 unifyMany f e θ [t1'] [t2] unify1 f e !θ !t1 t2@(FAbs _ _) = do @@ -1199,19 +1207,19 @@ unify1 _ _ !θ !s1 !s2 | isString s1, isString s2 = return θ -unify1 _ _ !θ !FInt !FReal = return θ +unify1 _ _ !θ FInt FReal = return θ -unify1 _ _ !θ !FReal !FInt = return θ +unify1 _ _ !θ FReal FInt = return θ unify1 f e !θ !t FInt = do - checkNumeric f t `withError` (errUnify e t FInt) + checkNumeric f t `withError` errUnify e t FInt return θ -unify1 f e !θ !FInt !t = do - checkNumeric f t `withError` (errUnify e FInt t) +unify1 f e !θ FInt !t = do + checkNumeric f t `withError` errUnify e FInt t return θ -unify1 f e !θ (FFunc !t1 !t2) (FFunc !t1' !t2') = do +unify1 f e !θ (FFunc !t1 !t2) (FFunc !t1' !t2') = unifyMany f e θ [t1, t2] [t1', t2'] unify1 f e θ (FObj a) !t = @@ -1227,7 +1235,7 @@ = throwErrorAt (errUnify e t1 t2) subst :: Int -> Sort -> Sort -> Sort -subst !j !tj !t@(FVar !i) +subst !j !tj t@(FVar !i) | i == j = tj | otherwise = t @@ -1255,15 +1263,15 @@ -------------------------------------------------------------------------------- instantiate !t = go t where - go (FAbs !i !t) = do - !t' <- instantiate t + go (FAbs !i !t') = do + !t'' <- instantiate t' !v <- fresh - return $ subst i (FVar v) t' - go !t = - return t + return $ subst i (FVar v) t'' + go !t' = + return t' unifyVar :: Env -> Maybe Expr -> TVSubst -> Int -> Sort -> CheckM TVSubst -unifyVar _ _ θ !i !t@(FVar !j) +unifyVar _ _ θ !i t@(FVar !j) = case lookupVar i θ of Just !t' -> if t == t' then return θ else return (updateVar j t' θ) Nothing -> return (updateVar i t θ) @@ -1288,8 +1296,8 @@ applyExpr Nothing e = e applyExpr (Just θ) e = Vis.mapExprOnExpr f e where - f (ECst e s) = ECst e (apply θ s) - f e = e + f (ECst e' s) = ECst e' (apply θ s) + f e' = e' -------------------------------------------------------------------------------- _applyCoercion :: Symbol -> Sort -> Sort -> Sort @@ -1343,14 +1351,14 @@ errElabExpr e = printf "Elaborate fails on %s" (showpp e) errUnifyMsg :: Maybe String -> Maybe Expr -> Sort -> Sort -> String -errUnifyMsg msgMb eo t1 t2 +errUnifyMsg msgMb eo t1 t2 = printf "Cannot unify %s with %s %s %s" (showpp t1) {- (show t1) -} (showpp t2) {-(show t2)-} (errUnifyExpr eo) msgStr - where - msgStr = case msgMb of { Nothing -> ""; Just s -> "<< " ++ s ++ " >>"} + where + msgStr = case msgMb of { Nothing -> ""; Just s -> "<< " ++ s ++ " >>"} errUnify :: Maybe Expr -> Sort -> Sort -> String -errUnify = errUnifyMsg Nothing +errUnify = errUnifyMsg Nothing errUnifyExpr :: Maybe Expr -> String errUnifyExpr Nothing = "" diff --git a/src/Language/Fixpoint/Types/Binary.hs b/src/Language/Fixpoint/Types/Binary.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Types/Binary.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | We need Binary instances as they are used to serialize specs in LH... --- -module Language.Fixpoint.Types.Binary where - -import qualified Data.Binary as B - -import Language.Fixpoint.Types as F - diff --git a/src/Language/Fixpoint/Types/Config.hs b/src/Language/Fixpoint/Types/Config.hs --- a/src/Language/Fixpoint/Types/Config.hs +++ b/src/Language/Fixpoint/Types/Config.hs @@ -14,6 +14,10 @@ -- * SMT Solver options , SMTSolver (..) + -- REST Options + , RESTOrdering (..) + , restOC + -- * Eliminate options , Eliminate (..) , useElim @@ -26,8 +30,11 @@ , queryFile ) where +import qualified Data.Store as S +import qualified Data.List as L import Data.Serialize (Serialize (..)) import Control.Monad +import Control.DeepSeq import GHC.Generics import System.Console.CmdArgs import System.Console.CmdArgs.Explicit @@ -80,25 +87,28 @@ , minimizeQs :: Bool -- ^ min .fq by delta debug (sat with min qualifiers) , minimizeKs :: Bool -- ^ min .fq by delta debug (sat with min kvars) , minimalSol :: Bool -- ^ shrink final solution by pruning redundant qualfiers from fixpoint - , etaElim :: Bool -- ^ eta eliminate function definitions + , etaElim :: Bool -- ^ eta eliminate function definitions , gradual :: Bool -- ^ solve "gradual" constraints , ginteractive :: Bool -- ^ interactive gradual solving , autoKuts :: Bool -- ^ ignore given kut variables , nonLinCuts :: Bool -- ^ Treat non-linear vars as cuts , noslice :: Bool -- ^ Disable non-concrete KVar slicing , rewriteAxioms :: Bool -- ^ Allow axiom instantiation via rewriting + , pleWithUndecidedGuards :: Bool -- ^ Unfold invocations with undecided guards in PLE + , interpreter :: Bool -- ^ Do not use the interpreter to assist PLE , oldPLE :: Bool -- ^ Use old version of PLE , noIncrPle :: Bool -- ^ Use incremental PLE , noEnvironmentReduction :: Bool -- ^ Don't use environment reduction , inlineANFBindings :: Bool -- ^ Inline ANF bindings. -- Sometimes improves performance and sometimes worsens it. - , checkCstr :: [Integer] -- ^ Only check these specific constraints + , checkCstr :: [Integer] -- ^ Only check these specific constraints , extensionality :: Bool -- ^ Enable extensional interpretation of function equality , rwTerminationCheck :: Bool -- ^ Enable termination checking for rewriting - , stdin :: Bool -- ^ Read input query from stdin + , stdin :: Bool -- ^ Read input query from stdin , json :: Bool -- ^ Render output in JSON format , noLazyPLE :: Bool , fuel :: Maybe Int -- ^ Maximum PLE "fuel" (unfold depth) (default=infinite) + , restOrdering :: String -- ^ Term ordering for use in REST } deriving (Eq,Data,Typeable,Show,Generic) instance Default Config where @@ -106,6 +116,29 @@ --------------------------------------------------------------------------------------- +data RESTOrdering = RESTKBO | RESTLPO | RESTRPO | RESTFuel Int + deriving (Eq, Data, Typeable, Generic) + +instance Default RESTOrdering where + def = RESTRPO + +instance Show RESTOrdering where + show RESTKBO = "kbo" + show RESTLPO = "lpo" + show RESTRPO = "rpo" + show (RESTFuel n) = "fuel" ++ show n + +instance Read RESTOrdering where + readsPrec _ s | "kbo" `L.isPrefixOf` s = [(RESTKBO, drop 3 s)] + readsPrec _ s | "lbo" `L.isPrefixOf` s = [(RESTLPO, drop 3 s)] + readsPrec _ s | "rpo" `L.isPrefixOf` s = [(RESTRPO, drop 3 s)] + readsPrec n s | "fuel" `L.isPrefixOf` s = do + (fuel', rest) <- readsPrec n (drop 4 s) + return (RESTFuel fuel', rest) + readsPrec _ _ = [] + +--------------------------------------------------------------------------------------- + data SMTSolver = Z3 | Cvc4 | Mathsat deriving (Eq, Data, Typeable, Generic) @@ -117,6 +150,8 @@ show Cvc4 = "cvc4" show Mathsat = "mathsat" +instance S.Store SMTSolver + --------------------------------------------------------------------------------------- -- | Eliminate describes the number of KVars to eliminate: -- None = use PA/Quals for ALL k-vars, i.e. no eliminate @@ -134,6 +169,9 @@ deriving (Eq, Data, Typeable, Generic) instance Serialize Eliminate +instance S.Store Eliminate +instance NFData SMTSolver +instance NFData Eliminate instance Default Eliminate where def = None @@ -182,7 +220,16 @@ , autoKuts = False &= help "Ignore given Kut vars, compute from scratch" , nonLinCuts = False &= help "Treat non-linear kvars as cuts" , noslice = False &= help "Disable non-concrete KVar slicing" - , rewriteAxioms = False &= help "allow axiom instantiation via rewriting" + , rewriteAxioms = False &= help "allow axiom instantiation via rewriting (PLE)" + , pleWithUndecidedGuards = + False + &= name "ple-with-undecided-guards" + &= help "Unfold invocations with undecided guards in PLE" + &= explicit + , interpreter = + False + &= name "interpreter" + &= help "Use the interpreter to assist PLE" , oldPLE = False &= help "Use old version of PLE" , noIncrPle = False &= help "Don't use incremental PLE" , noEnvironmentReduction = @@ -197,13 +244,16 @@ , "Sometimes improves performance and sometimes worsens it." , "Disabled by --no-environment-reduction" ]) - , checkCstr = [] &= help "Only check these specific constraint-ids" + , checkCstr = [] &= help "Only check these specific constraint-ids" , extensionality = False &= help "Allow extensional interpretation of extensionality" - , rwTerminationCheck = False &= help "Disable rewrite divergence checker" + , rwTerminationCheck = False &= help "Enable rewrite divergence checker" , stdin = False &= help "Read input query from stdin" , json = False &= help "Render result in JSON" , noLazyPLE = False &= help "Don't use lazy PLE" , fuel = Nothing &= help "Maximum fuel (per-function unfoldings) for PLE" + , restOrdering = "rpo" + &= name "rest-ordering" + &= help "Ordering Constraint Algebra to use for REST" } &= verbosity &= program "fixpoint" @@ -219,7 +269,7 @@ config = cmdArgsMode defConfig getOpts :: IO Config -getOpts = do +getOpts = do md <- cmdArgs defConfig whenNormal (putStrLn banner) return md @@ -227,6 +277,9 @@ banner :: String banner = "\n\nLiquid-Fixpoint Copyright 2013-21 Regents of the University of California.\n" ++ "All Rights Reserved.\n" + +restOC :: Config -> RESTOrdering +restOC cfg = read (restOrdering cfg) multicore :: Config -> Bool multicore cfg = cores cfg /= Just 1 diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs --- a/src/Language/Fixpoint/Types/Constraints.hs +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -12,6 +12,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the top-level QUERY data types and elements, -- including (Horn) implication & well-formedness constraints and sets. module Language.Fixpoint.Types.Constraints ( @@ -55,7 +57,7 @@ , qualifier , mkQual , remakeQual - , mkQ + , mkQ , qualBinds -- * Results @@ -90,10 +92,6 @@ import qualified Data.Store as S import Data.Generics (Data) import Data.Aeson hiding (Result) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Hashable @@ -156,12 +154,12 @@ = errorstar "gwInfo" updateWfCExpr :: (Expr -> Expr) -> WfC a -> WfC a -updateWfCExpr _ w@(WfC {}) = w -updateWfCExpr f w@(GWfC {}) = w{wexpr = f (wexpr w)} +updateWfCExpr _ w@WfC{} = w +updateWfCExpr f w@GWfC{} = w{wexpr = f (wexpr w)} isGWfc :: WfC a -> Bool -isGWfc (GWfC {}) = True -isGWfc (WfC {}) = False +isGWfc GWfC{} = True +isGWfc WfC{} = False instance HasGradual (WfC a) where isGradual = isGWfc @@ -188,7 +186,7 @@ } deriving (Generic, Functor) -instance Loc a => Loc (SimpC a) where +instance Loc a => Loc (SimpC a) where srcSpan = srcSpan . _cinfo strengthenHyp :: SInfo a -> [(Integer, Expr)] -> SInfo a @@ -207,9 +205,9 @@ strengthenBinds :: SInfo a -> M.HashMap BindId Expr -> SInfo a strengthenBinds si m = si { bs = mapBindEnv f (bs si) } where - f i (x, sr) = case M.lookup i m of - Nothing -> (x, sr) - Just e -> (x, strengthenSortedReft sr e) + f i (x, sr, l) = case M.lookup i m of + Nothing -> (x, sr, l) + Just e -> (x, strengthenSortedReft sr e, l) strengthenSortedReft :: SortedReft -> Expr -> SortedReft strengthenSortedReft (RR s (Reft (v, r))) e = RR s (Reft (v, pAnd [r, e])) @@ -231,7 +229,7 @@ sid :: c a -> Maybe Integer stag :: c a -> Tag sinfo :: c a -> a - clhs :: BindEnv -> c a -> [(Symbol, SortedReft)] + clhs :: BindEnv a -> c a -> [(Symbol, SortedReft)] crhs :: c a -> Expr instance TaggedC SimpC a where @@ -275,11 +273,11 @@ toGFixSol = GSol -data Result a = Result +data Result a = Result { resStatus :: !(FixResult a) , resSolution :: !FixSolution , resNonCutsSolution :: !FixSolution - , gresSolution :: !GFixSolution + , gresSolution :: !GFixSolution } deriving (Generic, Show, Functor) @@ -291,10 +289,10 @@ instance Semigroup (Result a) where r1 <> r2 = Result stat soln nonCutsSoln gsoln where - stat = (resStatus r1) <> (resStatus r2) - soln = (resSolution r1) <> (resSolution r2) + stat = resStatus r1 <> resStatus r2 + soln = resSolution r1 <> resSolution r2 nonCutsSoln = resNonCutsSolution r1 <> resNonCutsSolution r2 - gsoln = (gresSolution r1) <> (gresSolution r2) + gsoln = gresSolution r1 <> gresSolution r2 instance Monoid (Result a) where mempty = Result mempty mempty mempty mempty @@ -315,9 +313,9 @@ isUnsafe _ = False instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where - toFix (Safe stats) = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" + toFix (Safe stats) = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" -- toFix (UnknownError d) = text $ "Unknown Error: " ++ d - toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ pprSinfos "CRASH: " xs ++ [parens (text msg)] + toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ pprSinfos "CRASH: " (fst <$> xs) ++ [parens (text msg)] toFix (Unsafe _ xs) = vcat $ text "Unsafe:" : pprSinfos "WARNING: " xs pprSinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc] @@ -362,7 +360,7 @@ -- NOTE: this next line is printed this way for compatability with the OCAML solver $+$ text "reft" <+> toFix (RR t (Reft (v, PKVar k mempty))) $+$ toFixMeta (text "wf") (toFix (winfo w)) - $+$ if (isGWfc w) then (toFixMeta (text "expr") (toFix (wexpr w))) else mempty + $+$ if isGWfc w then toFixMeta (text "expr") (toFix (wexpr w)) else mempty (v, t, k) = wrft w toFixMeta :: Doc -> Doc -> Doc @@ -390,8 +388,8 @@ show = showpp ---------------------------------------------------------------- -instance S.Store QualPattern -instance S.Store QualParam +instance S.Store QualPattern +instance S.Store QualParam instance S.Store Qualifier instance S.Store Kuts instance S.Store HOInfo @@ -402,8 +400,8 @@ instance (S.Store a) => S.Store (SimpC a) instance (S.Store (c a), S.Store a) => S.Store (GInfo c a) -instance NFData QualPattern -instance NFData QualParam +instance NFData QualPattern +instance NFData QualParam instance NFData Qualifier instance NFData Kuts instance NFData HOInfo @@ -473,7 +471,7 @@ addIds :: [SubC a] -> [(Integer, SubC a)] addIds = zipWith (\i c -> (i, shiftId i $ c {_sid = Just i})) [1..] - where + where -- Adding shiftId to have distinct VV for SMT conversion shiftId i c = c { slhs = shiftSR i $ slhs c } { srhs = shiftSR i $ srhs c } @@ -483,7 +481,7 @@ -------------------------------------------------------------------------------- -- | Qualifiers ---------------------------------------------------------------- -------------------------------------------------------------------------------- -data Qualifier = Q +data Qualifier = Q { qName :: !Symbol -- ^ Name , qParams :: [QualParam] -- ^ Parameters , qBody :: !Expr -- ^ Predicate @@ -491,15 +489,15 @@ } deriving (Eq, Ord, Show, Data, Typeable, Generic) -data QualParam = QP +data QualParam = QP { qpSym :: !Symbol - , qpPat :: !QualPattern + , qpPat :: !QualPattern , qpSort :: !Sort - } + } deriving (Eq, Ord, Show, Data, Typeable, Generic) -data QualPattern - = PatNone -- ^ match everything +data QualPattern + = PatNone -- ^ match everything | PatPrefix !Symbol !Int -- ^ str . $i i.e. match prefix 'str' with suffix bound to $i | PatSuffix !Int !Symbol -- ^ $i . str i.e. match suffix 'str' with prefix bound to $i | PatExact !Symbol -- ^ str i.e. exactly match 'str' @@ -513,31 +511,31 @@ where l = qPos q -instance Subable Qualifier where - syms = qualFreeSymbols +instance Subable Qualifier where + syms = qualFreeSymbols subst = mapQualBody . subst substf = mapQualBody . substf substa = mapQualBody . substa mapQualBody :: (Expr -> Expr) -> Qualifier -> Qualifier mapQualBody f q = q { qBody = f (qBody q) } - + qualFreeSymbols :: Qualifier -> [Symbol] -qualFreeSymbols q = filter (not . isPrim) xs +qualFreeSymbols q = filter (not . isPrim) xs where - xs = syms (qBody q) L.\\ syms (qpSym <$> qParams q) + xs = syms (qBody q) L.\\ syms (qpSym <$> qParams q) -instance Fixpoint QualParam where - toFix (QP x _ t) = toFix (x, t) +instance Fixpoint QualParam where + toFix (QP x _ t) = toFix (x, t) -instance PPrint QualParam where - pprintTidy k (QP x pat t) = pprintTidy k x <+> pprintTidy k pat <+> colon <+> pprintTidy k t +instance PPrint QualParam where + pprintTidy k (QP x pat t) = pprintTidy k x <+> pprintTidy k pat <+> colon <+> pprintTidy k t -instance PPrint QualPattern where - pprintTidy _ PatNone = "" +instance PPrint QualPattern where + pprintTidy _ PatNone = "" pprintTidy k (PatPrefix s i) = "as" <+> pprintTidy k s <+> ("$" <-> pprint i) - pprintTidy k (PatSuffix s i) = "as" <+> ("$" <-> pprint i) <+> pprintTidy k s - pprintTidy k (PatExact s ) = "~" <+> pprintTidy k s + pprintTidy k (PatSuffix s i) = "as" <+> ("$" <-> pprint i) <+> pprintTidy k s + pprintTidy k (PatExact s ) = "~" <+> pprintTidy k s instance Fixpoint Qualifier where toFix = pprQual @@ -556,7 +554,7 @@ xs = L.delete v $ L.nub $ syms p xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..] -mkQ :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier +mkQ :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier mkQ n = Q n . qualParams qualParams :: [(Symbol, Sort)] -> [QualParam] @@ -579,13 +577,13 @@ -- | constructing qualifiers mkQual :: Symbol -> [QualParam] -> Expr -> SourcePos -> Qualifier -mkQual n qps p = Q n qps' p +mkQual n qps p = Q n qps' p where qps' = zipWith (\qp t' -> qp { qpSort = t'}) qps ts' - ts' = gSorts (qpSort <$> qps) + ts' = gSorts (qpSort <$> qps) gSorts :: [Sort] -> [Sort] -gSorts ts = substVars su <$> ts +gSorts ts = substVars su <$> ts where su = (`zip` [0..]) . sortNub . concatMap sortVars $ ts @@ -631,7 +629,7 @@ deriving (Eq, Show, Generic) instance Fixpoint Kuts where - toFix (KS s) = vcat $ (("cut " <->) . toFix) <$> L.sort (S.toList s) + toFix (KS s) = vcat $ ("cut " <->) . toFix <$> L.sort (S.toList s) ksMember :: KVar -> Kuts -> Bool ksMember k (KS s) = S.member k s @@ -648,7 +646,7 @@ ------------------------------------------------------------------------ fi :: [SubC a] -> [WfC a] - -> BindEnv + -> BindEnv a -> SEnv Sort -> SEnv Sort -> Kuts @@ -659,7 +657,7 @@ -> [Triggered Expr] -> AxiomEnv -> [DataDecl] - -> [BindId] + -> [BindId] -> GInfo SubC a fi cs ws binds ls ds ks qs bi aHO aHOq es axe adts ebs = FI { cm = M.fromList $ addIds cs @@ -674,7 +672,7 @@ , asserts = es , ae = axe , ddecls = adts - , ebinds = ebs + , ebinds = ebs } where --TODO handle duplicates gracefully instead (merge envs by intersect?) @@ -685,7 +683,7 @@ -- | Top-level Queries ------------------------------------------------------------------------ -data FInfoWithOpts a = FIO +data FInfoWithOpts a = FIO { fioFI :: FInfo a , fioOpts :: [String] } @@ -693,7 +691,7 @@ type FInfo a = GInfo SubC a type SInfo a = GInfo SimpC a -data HOInfo = HOI +data HOInfo = HOI { hoBinds :: Bool -- ^ Allow higher order binds in the environemnt , hoQuals :: Bool -- ^ Allow higher order quals } @@ -703,10 +701,10 @@ allowHO = hoBinds . hoInfo allowHOquals = hoQuals . hoInfo -data GInfo c a = FI +data GInfo c a = FI { cm :: !(M.HashMap SubcId (c a)) -- ^ cst id |-> Horn Constraint , ws :: !(M.HashMap KVar (WfC a)) -- ^ Kvar |-> WfC defining its scope/args - , bs :: !BindEnv -- ^ Bind |-> (Symbol, SortedReft) + , bs :: !(BindEnv a) -- ^ Bind |-> (Symbol, SortedReft) , ebinds :: ![BindId] -- ^ Subset of existential binders , gLits :: !(SEnv Sort) -- ^ Global Constant symbols , dLits :: !(SEnv Sort) -- ^ Distinct Constant symbols @@ -732,37 +730,37 @@ mempty = HOI False False instance Semigroup (GInfo c a) where - i1 <> i2 = FI { cm = (cm i1) <> (cm i2) - , ws = (ws i1) <> (ws i2) - , bs = (bs i1) <> (bs i2) - , ebinds = (ebinds i1) <> (ebinds i2) - , gLits = (gLits i1) <> (gLits i2) - , dLits = (dLits i1) <> (dLits i2) - , kuts = (kuts i1) <> (kuts i2) - , quals = (quals i1) <> (quals i2) - , bindInfo = (bindInfo i1) <> (bindInfo i2) - , ddecls = (ddecls i1) <> (ddecls i2) - , hoInfo = (hoInfo i1) <> (hoInfo i2) - , asserts = (asserts i1) <> (asserts i2) - , ae = (ae i1) <> (ae i2) + i1 <> i2 = FI { cm = cm i1 <> cm i2 + , ws = ws i1 <> ws i2 + , bs = bs i1 <> bs i2 + , ebinds = ebinds i1 <> ebinds i2 + , gLits = gLits i1 <> gLits i2 + , dLits = dLits i1 <> dLits i2 + , kuts = kuts i1 <> kuts i2 + , quals = quals i1 <> quals i2 + , bindInfo = bindInfo i1 <> bindInfo i2 + , ddecls = ddecls i1 <> ddecls i2 + , hoInfo = hoInfo i1 <> hoInfo i2 + , asserts = asserts i1 <> asserts i2 + , ae = ae i1 <> ae i2 } instance Monoid (GInfo c a) where mempty = FI { cm = M.empty - , ws = mempty - , bs = mempty - , ebinds = mempty - , gLits = mempty - , dLits = mempty - , kuts = mempty - , quals = mempty - , bindInfo = mempty - , ddecls = mempty - , hoInfo = mempty - , asserts = mempty + , ws = mempty + , bs = mempty + , ebinds = mempty + , gLits = mempty + , dLits = mempty + , kuts = mempty + , quals = mempty + , bindInfo = mempty + , ddecls = mempty + , hoInfo = mempty + , asserts = mempty , ae = mempty - } + } instance PTable (SInfo a) where ptable z = DocTable [ (text "# Sub Constraints", pprint $ length $ cm z) @@ -807,6 +805,7 @@ | mdata = vcat . map metaDoc . M.toList . bindInfo | otherwise = \_ -> text "\n" +infixl 9 $++$ ($++$) :: Doc -> Doc -> Doc x $++$ y = x $+$ text "\n" $+$ y @@ -842,7 +841,7 @@ where fi' = fi { bs = be', cm = cm' } m' = M.insert i bId m - (bId, be') = insertBindEnv x sr $ bs fi + (bId, be') = insertBindEnv x sr (sinfo c) (bs fi) cm' = M.insert i c' $ cm fi c' = c { _senv = insertsIBindEnv [bId] $ senv c } sr = slhs c @@ -861,7 +860,7 @@ -- Assumes the sort and the bind of the lhs is the same as the sort -- and the bind of the rhs -simpcToSubc :: BindEnv -> SimpC a -> SubC a +simpcToSubc :: BindEnv a -> SimpC a -> SubC a simpcToSubc env s = SubC { _senv = deleteIBindEnv (cbind s) (senv s) , slhs = sr @@ -871,7 +870,7 @@ , _sinfo = sinfo s } where - (b, sr) = lookupBindEnv (cbind s) env + (b, sr, _) = lookupBindEnv (cbind s) env --------------------------------------------------------------------------- -- | Top level Solvers ---------------------------------------------------- @@ -879,7 +878,7 @@ type Solver a = Config -> FInfo a -> IO (Result (Integer, a)) -------------------------------------------------------------------------------- -saveQuery :: Fixpoint a => Config -> FInfo a -> IO () +saveQuery :: (Fixpoint a) => Config -> FInfo a -> IO () -------------------------------------------------------------------------------- saveQuery cfg fi = {- when (save cfg) $ -} do let fi' = void fi @@ -915,14 +914,10 @@ instance S.Store AxiomEnv instance S.Store Rewrite instance S.Store Equation -instance S.Store SMTSolver -instance S.Store Eliminate instance NFData AutoRewrite instance NFData AxiomEnv instance NFData Rewrite instance NFData Equation -instance NFData SMTSolver -instance NFData Eliminate dedupAutoRewrites :: M.HashMap SubcId [AutoRewrite] -> [AutoRewrite] dedupAutoRewrites = Set.toList . Set.unions . map Set.fromList . M.elems @@ -930,10 +925,10 @@ instance Semigroup AxiomEnv where a1 <> a2 = AEnv aenvEqs' aenvSimpl' aenvExpand' aenvAutoRW' where - aenvEqs' = (aenvEqs a1) <> (aenvEqs a2) - aenvSimpl' = (aenvSimpl a1) <> (aenvSimpl a2) - aenvExpand' = (aenvExpand a1) <> (aenvExpand a2) - aenvAutoRW' = (aenvAutoRW a1) <> (aenvAutoRW a2) + aenvEqs' = aenvEqs a1 <> aenvEqs a2 + aenvSimpl' = aenvSimpl a1 <> aenvSimpl a2 + aenvExpand' = aenvExpand a1 <> aenvExpand a2 + aenvAutoRW' = aenvAutoRW a1 <> aenvAutoRW a2 instance Monoid AxiomEnv where mempty = AEnv [] [] (M.fromList []) (M.fromList []) @@ -976,7 +971,6 @@ , arRHS :: Expr } deriving (Eq, Ord, Show, Generic) -instance Hashable SortedReft instance Hashable AutoRewrite @@ -991,6 +985,7 @@ fixRW rw@(AutoRewrite args lhs rhs) = text ("autorewrite " ++ show (hash rw)) <+> hsep (map toFix args) + <+> text "=" <+> text "{" <+> toFix lhs <+> text "=" @@ -1022,9 +1017,6 @@ pairdoc (x,y) = text $ show x ++ " : " ++ show y renderExpand [] = empty renderExpand xs = text "expand" <+> toFix xs - -instance Fixpoint Doc where - toFix = id instance Fixpoint Equation where toFix (Equ f xs e s _) = "define" <+> toFix f <+> ppArgs xs <+> ":" <+> toFix s <+> text "=" <+> braces (parens (toFix e)) diff --git a/src/Language/Fixpoint/Types/Environments.hs b/src/Language/Fixpoint/Types/Environments.hs --- a/src/Language/Fixpoint/Types/Environments.hs +++ b/src/Language/Fixpoint/Types/Environments.hs @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -16,7 +14,8 @@ module Language.Fixpoint.Types.Environments ( -- * Environments - SEnv, SESearch(..) + SEnv(..) + , SESearch(..) , emptySEnv, toListSEnv, fromListSEnv, fromMapSEnv , mapSEnvWithKey, mapSEnv, mapMSEnv , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv, unionSEnv, unionSEnv' @@ -63,10 +62,6 @@ import qualified Data.Store as S import qualified Data.List as L import Data.Generics (Data) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Data.Typeable (Typeable) import GHC.Generics (Generic) import qualified Data.HashMap.Strict as M @@ -101,15 +96,15 @@ pprintTidy k (BE _ m) = pprintTidy k m -- Invariant: All BindIds in the map are less than beSize -type BindEnv = SizedEnv (Symbol, SortedReft) -newtype EBindEnv = EB BindEnv +type BindEnv a = SizedEnv (Symbol, SortedReft, a) +newtype EBindEnv a = EB (BindEnv a) -splitByQuantifiers :: BindEnv -> [BindId] -> (BindEnv, EBindEnv) -splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> not (elem k ebs)) bs +splitByQuantifiers :: BindEnv a -> [BindId] -> (BindEnv a, EBindEnv a) +splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> notElem k ebs) bs , EB $ BE i $ M.filterWithKey (\k _ -> elem k ebs) bs ) --- data SolEnv = SolEnv { soeBinds :: !BindEnv } +-- data SolEnv = SolEnv { soeBinds :: !BindEnv } -- deriving (Eq, Show, Generic) instance PPrint a => PPrint (SEnv a) where @@ -173,7 +168,7 @@ Nothing -> Alts $ symbol <$> alts where alts = takeMin $ zip (editDistance x' <$> ss) ss - ss = symbolString <$> fst <$> M.toList env + ss = symbolString . fst <$> M.toList env x' = symbolString x takeMin xs = [z | (d, z) <- xs, d == getMin xs] getMin = minimum . (fst <$>) @@ -209,41 +204,46 @@ fromListIBindEnv = FB . S.fromList -- | Functions for Global Binder Environment -insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv) -insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m)) +insertBindEnv :: Symbol -> SortedReft -> a -> BindEnv a -> (BindId, BindEnv a) +insertBindEnv x r a (BE n m) = (n, BE (n + 1) (M.insert n (x, r, a) m)) -fromListBindEnv :: [(BindId, (Symbol, SortedReft))] -> BindEnv +fromListBindEnv :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a fromListBindEnv xs = BE (length xs) (M.fromList xs) -emptyBindEnv :: BindEnv +emptyBindEnv :: BindEnv a emptyBindEnv = BE 0 M.empty -filterBindEnv :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv -> BindEnv -filterBindEnv f (BE n be) = BE n (M.filterWithKey (\ n (x, r) -> f n x r) be) +filterBindEnv :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv a -> BindEnv a +filterBindEnv f (BE n be) = BE n (M.filterWithKey (\ n' (x, r, _) -> f n' x r) be) -bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv +bindEnvFromList :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a bindEnvFromList [] = emptyBindEnv bindEnvFromList bs = BE (1 + maxId) be where - maxId = maximum $ fst3 <$> bs - be = M.fromList [(n, (x, r)) | (n, x, r) <- bs] + maxId = maximum [ n | (n,(_,_,_)) <- bs ] + be = M.fromList bs -elemsBindEnv :: BindEnv -> [BindId] -elemsBindEnv be = fst3 <$> bindEnvToList be +elemsBindEnv :: BindEnv a -> [BindId] +elemsBindEnv be = fst <$> bindEnvToList be -bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)] -bindEnvToList (BE _ be) = [(n, x, r) | (n, (x, r)) <- M.toList be] +bindEnvToList :: BindEnv a -> [(BindId, (Symbol, SortedReft, a))] +bindEnvToList (BE _ be) = M.toList be -mapBindEnv :: (BindId -> (Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv -mapBindEnv f (BE n m) = BE n $ M.mapWithKey f m +mapBindEnv :: (BindId -> (Symbol, SortedReft, a) -> (Symbol, SortedReft, a)) -> BindEnv a -> BindEnv a +mapBindEnv f (BE n m) = BE n (M.mapWithKey f m) + -- where + -- f' k (x, y, a) = let (x', y') = f k (x, y) in (x', y', a) + -- (\i z -> tracepp (msg i z) $ f z) m -- where -- msg i z = "beMap " ++ show i ++ " " ++ show z -mapWithKeyMBindEnv :: (Monad m) => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv -> m BindEnv -mapWithKeyMBindEnv f (BE n m) = (BE n . M.fromList) <$> mapM f (M.toList m) +mapWithKeyMBindEnv :: (Monad m) => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv a -> m (BindEnv a) +mapWithKeyMBindEnv f (BE n m) = BE n . M.fromList <$> mapM f' (M.toList m) + where + f' (k, (x, y, a)) = do { (k', (x', y')) <- f (k, (x, y)) ; return (k', (x', y', a)) } -lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft) +lookupBindEnv :: BindId -> BindEnv a -> (Symbol, SortedReft, a) lookupBindEnv k (BE _ m) = fromMaybe err (M.lookup k m) where err = errorstar $ "lookupBindEnv: cannot find binder" ++ show k @@ -266,24 +266,27 @@ diffIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv diffIBindEnv (FB m1) (FB m2) = FB $ m1 `S.difference` m2 -adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv -adjustBindEnv f i (BE n m) = BE n $ M.adjust f i m +adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv a -> BindEnv a +adjustBindEnv f i (BE n m) = BE n (M.adjust f' i m) + where + f' (x, y, a) = let (x', y') = f (x, y) in (x', y', a) -deleteBindEnv :: BindId -> BindEnv -> BindEnv + +deleteBindEnv :: BindId -> BindEnv a -> BindEnv a deleteBindEnv i (BE n m) = BE n $ M.delete i m instance Functor SEnv where fmap = mapSEnv -instance Fixpoint EBindEnv where +instance Fixpoint (EBindEnv a) where toFix (EB (BE _ m)) = vcat $ map toFixBind $ hashMapToAscList m where - toFixBind (i, (x, r)) = "ebind" <+> toFix i <+> toFix x <+> ": { " <+> toFix (sr_sort r) <+> " }" + toFixBind (i, (x, r, _)) = "ebind" <+> toFix i <+> toFix x <+> ": { " <+> toFix (sr_sort r) <+> " }" -instance Fixpoint BindEnv where +instance Fixpoint (BindEnv a) where toFix (BE _ m) = vcat $ map toFixBind $ hashMapToAscList m where - toFixBind (i, (x, r)) = "bind" <+> toFix i <+> toFix x <+> ":" <+> toFix r + toFixBind (i, (x, r, _)) = "bind" <+> toFix i <+> toFix x <+> ":" <+> toFix r instance (Fixpoint a) => Fixpoint (SEnv a) where toFix (SE m) = toFix (hashMapToAscList m) @@ -297,31 +300,31 @@ instance Monoid (SEnv a) where mempty = SE M.empty -instance Semigroup BindEnv where +instance Semigroup (BindEnv a) where (BE 0 _) <> b = b b <> (BE 0 _) = b _ <> _ = errorstar "mappend on non-trivial BindEnvs" -instance Monoid BindEnv where +instance Monoid (BindEnv a) where mempty = BE 0 M.empty mappend = (<>) -envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)] -envCs be env = [lookupBindEnv i be | i <- elemsIBindEnv env] +envCs :: BindEnv a -> IBindEnv -> [(Symbol, SortedReft)] +envCs be env = [(x, y) | i <- elemsIBindEnv env, let (x, y, _) = lookupBindEnv i be] -instance Fixpoint (IBindEnv) where +instance Fixpoint IBindEnv where toFix (FB ids) = text "env" <+> toFix ids -------------------------------------------------------------------------------- instance NFData Packs instance NFData IBindEnv -instance NFData BindEnv +instance NFData a => NFData (BindEnv a) instance (NFData a) => NFData (SEnv a) instance S.Store Packs instance S.Store IBindEnv -instance S.Store BindEnv +instance (S.Store a) => S.Store (BindEnv a) instance (S.Store a) => S.Store (SEnv a) -- instance (Hashable a, Eq a, S.Store a) => S.Store (S.HashSet a) where -- put = B.put . S.toList @@ -335,7 +338,7 @@ deriving (Eq, Show, Generic) instance Fixpoint Packs where - toFix (Packs m) = vcat $ (("pack" <+>) . toFix) <$> kIs + toFix (Packs m) = vcat $ ("pack" <+>) . toFix <$> kIs where kIs = L.sortBy (compare `on` snd) . M.toList $ m diff --git a/src/Language/Fixpoint/Types/Errors.hs b/src/Language/Fixpoint/Types/Errors.hs --- a/src/Language/Fixpoint/Types/Errors.hs +++ b/src/Language/Fixpoint/Types/Errors.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -10,7 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Language.Fixpoint.Types.Errors ( -- * Concrete Location Type @@ -59,10 +58,6 @@ import Data.Aeson hiding (Error, Result) import Data.Generics (Data) import Data.Typeable -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Control.DeepSeq -- import Data.Hashable import qualified Data.Store as S @@ -102,7 +97,7 @@ errs :: Error -> [Error1] -errs (Error es) = es +errs (Error es) = es data Error1 = Error1 { errLoc :: SrcSpan @@ -123,7 +118,7 @@ toFix = pprint instance Exception Error -instance Exception (FixResult Error) +-- instance Exception (FixResult Error) --------------------------------------------------------------------- @@ -172,19 +167,20 @@ -- | Result --------------------------------------------------------- --------------------------------------------------------------------- -data FixResult a = Crash [a] String - | Safe Solver.Stats +data FixResult a + = Crash [(a, Maybe String)] String + | Unsafe Solver.Stats ![a] + | Safe Solver.Stats -- ^ The 'Solver' statistics, which include also the constraints /actually/ -- checked. A program will be \"trivially safe\" in case this -- number is 0. - | Unsafe Solver.Stats ![a] - deriving (Data, Typeable, Foldable, Traversable, Show, Generic) + deriving (Data, Typeable, Foldable, Functor, Traversable, Show, Generic) instance (NFData a) => NFData (FixResult a) instance Eq a => Eq (FixResult a) where Crash xs _ == Crash ys _ = xs == ys - Unsafe s1 xs == Unsafe s2 ys = xs == ys && s1 == s2 + Unsafe s1 xs == Unsafe s2 ys = xs == ys && s1 == s2 Safe s1 == Safe s2 = s1 == s2 _ == _ = False @@ -192,38 +188,27 @@ Safe s1 <> Safe s2 = Safe (s1 <> s2) Safe _ <> x = x x <> Safe _ = x - _ <> c@(Crash{}) = c - c@(Crash{}) <> _ = c + _ <> c@Crash{} = c + c@Crash{} <> _ = c (Unsafe s1 xs) <> (Unsafe s2 ys) = Unsafe (s1 <> s2) (xs ++ ys) instance Monoid (FixResult a) where mempty = Safe mempty mappend = (<>) -instance Functor FixResult where - fmap f (Crash xs msg) = Crash (f <$> xs) msg - fmap f (Unsafe s xs) = Unsafe s (f <$> xs) - fmap _ (Safe stats) = Safe stats - --- instance (ToJSON a) => ToJSON (FixResult a) where --- toJSON (Safe _ ) = object [ "result" .= String "safe" ] - --- toJSON (Unsafe _ ts) = object [ "result" .= String "unsafe" --- , "tags" .= toJSON ts --- ] --- toJSON (Crash ts msg) = object [ "result" .= String "crash" --- , "message" .= msg --- , "tags" .= toJSON ts --- ] +-- instance Functor FixResult where +-- fmap f (Crash xs msg) = Crash (f <$> xs) msg +-- fmap f (Unsafe s xs) = Unsafe s (f <$> xs) +-- fmap _ (Safe stats) = Safe stats instance (ToJSON a) => ToJSON (FixResult a) where toJSON = genericToJSON defaultOptions toEncoding = genericToEncoding defaultOptions resultDoc :: (Fixpoint a) => FixResult a -> Doc -resultDoc (Safe stats) = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" -resultDoc (Crash xs msg) = vcat $ text ("Crash!: " ++ msg) : ((("CRASH:" <+>) . toFix) <$> xs) -resultDoc (Unsafe _ xs) = vcat $ text "Unsafe:" : ((("WARNING:" <+>) . toFix) <$> xs) +resultDoc (Safe stats) = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" +resultDoc (Crash xs msg) = vcat $ text ("Crash!: " ++ msg) : (("CRASH:" <+>) . toFix . fst <$> xs) +resultDoc (Unsafe _ xs) = vcat $ text "Unsafe:" : (("WARNING:" <+>) . toFix <$> xs) instance (Fixpoint a) => PPrint (FixResult a) where pprintTidy _ = resultDoc diff --git a/src/Language/Fixpoint/Types/Graduals.hs b/src/Language/Fixpoint/Types/Graduals.hs --- a/src/Language/Fixpoint/Types/Graduals.hs +++ b/src/Language/Fixpoint/Types/Graduals.hs @@ -5,13 +5,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the top-level SOLUTION data types, -- including various indices used for solving. @@ -44,10 +42,6 @@ import Control.Monad.State.Lazy import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import qualified Language.Fixpoint.SortCheck as So import Language.Fixpoint.Solver.Sanitize (symbolEnv) @@ -84,7 +78,7 @@ ------------------------------------------------------------------------------- -- | Make each gradual appearence unique ------------------------------------- ------------------------------------------------------------------------------- -uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> (SInfo a) +uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> SInfo a uniquify fi = fi{cm = cm', ws = ws', bs = bs'} where @@ -92,54 +86,52 @@ ws' = expandWF km (ws fi) uniquifyCS :: (NFData a, Fixpoint a, Loc a) - => BindEnv + => BindEnv a -> M.HashMap SubcId (SimpC a) - -> (M.HashMap SubcId (SimpC a), M.HashMap KVar [(KVar, Maybe SrcSpan)], BindEnv) + -> (M.HashMap SubcId (SimpC a), M.HashMap KVar [(KVar, Maybe SrcSpan)], BindEnv a) uniquifyCS bs cs = (x, km, benv st) --- = (x, km, mapBindEnv (\i (x,r) -> if i `elem` ubs st then (x, ungrad r) else (x, r)) $ benv st) where (x, st) = runState (uniq cs) (initUniqueST bs) km = kmap st - -- gs = [x | xs <- M.elems km, (x,_) <- xs] -class Unique a where - uniq :: a -> UniqueM a +class Unique ann a where + uniq :: a -> UniqueM ann a -instance Unique a => Unique (M.HashMap SubcId a) where +instance Unique ann a => Unique ann (M.HashMap SubcId a) where uniq m = M.fromList <$> mapM (\(i,x) -> (i,) <$> uniq x) (M.toList m) -instance Loc a => Unique (SimpC a) where +instance Loc a => Unique a (SimpC a) where uniq cs = do updateLoc $ srcSpan $ _cinfo cs rhs <- uniq (_crhs cs) env <- uniq (_cenv cs) return cs{_crhs = rhs, _cenv = env} -instance Unique IBindEnv where +instance Unique ann IBindEnv where uniq env = withCache (fromListIBindEnv <$> mapM uniq (elemsIBindEnv env)) -instance Unique BindId where +instance Unique ann BindId where uniq i = do bs <- benv <$> get - let (x, t) = lookupBindEnv i bs + let (x, t, ann) = lookupBindEnv i bs resetChange t' <- uniq t hasChanged <- change <$> get if hasChanged - then do let (i', bs') = insertBindEnv x t' bs + then do let (i', bs') = insertBindEnv x t' ann bs updateBEnv i bs' return i' else return i -instance Unique SortedReft where +instance Unique ann SortedReft where uniq (RR s r) = RR s <$> uniq r -instance Unique Reft where - uniq (Reft (x,e)) = (Reft . (x,)) <$> uniq e +instance Unique ann Reft where + uniq (Reft (x,e)) = Reft . (x,) <$> uniq e -instance Unique Expr where +instance Unique ann Expr where uniq = mapMExpr go where go (PGrad k su i e) = do @@ -152,46 +144,46 @@ -- | The Unique Monad --------------------------------------------------------- ------------------------------------------------------------------------------- -type UniqueM = State UniqueST -data UniqueST +type UniqueM ann = State (UniqueST ann) +data UniqueST a = UniqueST { freshId :: Integer , kmap :: M.HashMap KVar [(KVar, Maybe SrcSpan)] , change :: Bool , cache :: M.HashMap KVar KVar , uloc :: Maybe SrcSpan , ubs :: [BindId] - , benv :: BindEnv + , benv :: BindEnv a } -updateLoc :: SrcSpan -> UniqueM () +updateLoc :: SrcSpan -> UniqueM ann () updateLoc x = modify $ \s -> s{uloc = Just x} -withCache :: UniqueM a -> UniqueM a +withCache :: UniqueM ann a -> UniqueM ann a withCache act = do emptyCache a <- act emptyCache return a -emptyCache :: UniqueM () +emptyCache :: UniqueM ann () emptyCache = modify $ \s -> s{cache = mempty} -addCache :: KVar -> KVar -> UniqueM () +addCache :: KVar -> KVar -> UniqueM ann () addCache k k' = modify $ \s -> s{cache = M.insert k k' (cache s)} -updateBEnv :: BindId -> BindEnv -> UniqueM () -updateBEnv i bs = modify $ \s -> s{benv = bs, ubs = i:(ubs s)} +updateBEnv :: BindId -> BindEnv a -> UniqueM a () +updateBEnv i bs = modify $ \s -> s{benv = bs, ubs = i : ubs s} -setChange :: UniqueM () +setChange :: UniqueM ann () setChange = modify $ \s -> s{change = True} -resetChange :: UniqueM () +resetChange :: UniqueM ann () resetChange = modify $ \s -> s{change = False} -initUniqueST :: BindEnv -> UniqueST +initUniqueST :: BindEnv a -> UniqueST a initUniqueST = UniqueST 0 mempty False mempty Nothing mempty -freshK, freshK' :: KVar -> UniqueM KVar +freshK, freshK' :: KVar -> UniqueM ann KVar freshK k = do setChange cached <- cache <$> get @@ -202,15 +194,15 @@ freshK' k = do i <- freshId <$> get - modify $ (\s -> s{freshId = i + 1}) + modify (\s -> s{freshId = i + 1}) let k' = KV $ gradIntSymbol i addK k k' addCache k k' return k' -addK :: KVar -> KVar -> UniqueM () +addK :: KVar -> KVar -> UniqueM ann () addK key val = - modify $ (\s -> s{kmap = M.insertWith (++) key [(val, uloc s)] (kmap s)}) + modify (\s -> s{kmap = M.insertWith (++) key [(val, uloc s)] (kmap s)}) ------------------------------------------------------------------------------- -- | expandWF ----------------------------------------------------------------- @@ -221,16 +213,18 @@ -> M.HashMap KVar (WfC a) -> M.HashMap KVar (WfC a) expandWF km ws - = M.fromList $ + = M.fromList ([(k, updateKVar k src w) | (i, w) <- gws, (kw, ks) <- km', kw == i, (k, src) <- ks] ++ kws) where (gws, kws) = L.partition (isGWfc . snd) $ M.toList ws km' = M.toList km - updateKVar k src wfc = wfc { wrft = (\(v,s,_) -> (v,s,k)) $ wrft wfc - , wloc = (wloc wfc){gused = src} - } + updateKVar k src wfc = let wrft' = (\(v,s,_) -> (v,s,k)) $ wrft wfc in + case wfc of + GWfC{} -> wfc { wrft = wrft', wloc = (wloc wfc){gused = src} } + WfC{} -> wfc { wrft = wrft' } + ------------------------------------------------------------------------------- -- | Substitute Gradual Solution --------------------------------------------- ------------------------------------------------------------------------------- @@ -253,8 +247,8 @@ instance Gradual (SimpC a) where gsubst su c = c {_crhs = gsubst su (_crhs c)} -instance Gradual BindEnv where - gsubst su = mapBindEnv (\_ (x, r) -> (x, gsubst su r)) +instance Gradual (BindEnv a) where + gsubst su = mapBindEnv (\_ (x, r, l) -> (x, gsubst su r, l)) instance Gradual v => Gradual (M.HashMap k v) where gsubst su = M.map (gsubst su) diff --git a/src/Language/Fixpoint/Types/Names.hs b/src/Language/Fixpoint/Types/Names.hs --- a/src/Language/Fixpoint/Types/Names.hs +++ b/src/Language/Fixpoint/Types/Names.hs @@ -5,12 +5,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | This module contains Haskell variables representing globally visible names. -- Rather than have strings floating around the system, all constant names @@ -43,12 +42,13 @@ -- , isCtorSymbol , isNontrivialVV , isDummy + , isFixKey -- * Destructors , prefixOfSym , suffixOfSym , stripPrefix - , stripSuffix + , stripSuffix , consSym , unconsSym , dropSym @@ -82,7 +82,7 @@ , kArgSymbol , existSymbol , suffixSymbol - , mappendSym + , mappendSym -- * Unwrapping Symbols , unLitSymbol @@ -130,9 +130,6 @@ import Control.Arrow (second) import Data.Char (ord) import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,14,0) -import Data.Monoid ((<>)) -#endif import Data.Generics (Data) import Data.Hashable (Hashable (..)) import qualified Data.HashSet as S hiding (size) @@ -329,10 +326,7 @@ isUnsafeChar :: Char -> Bool isUnsafeChar c = let ic = ord c - in if ic < Arr.numElements okSymChars then - not (okSymChars Arr.! ic) - else - True + in ic >= Arr.numElements okSymChars || not (okSymChars Arr.! ic) keywords :: S.HashSet T.Text keywords = S.fromList [ "env" @@ -434,7 +428,7 @@ vv Nothing = vvName isNontrivialVV :: Symbol -> Bool -isNontrivialVV = not . (vv Nothing ==) +isNontrivialVV = (vv Nothing /=) vvCon, dummySymbol :: Symbol vvCon = vvName `suffixSymbol` "F" @@ -555,7 +549,7 @@ buildMany :: [Builder.Builder] -> Builder.Builder buildMany [] = mempty buildMany [b] = b -buildMany (b:bs) = b <> mconcat [ " " <> b | b <- bs ] +buildMany (b:bs) = b <> mconcat [ " " <> b' | b' <- bs ] ---------------------------------------------------------------------------- --------------- Global Name Definitions ------------------------------------ @@ -640,11 +634,11 @@ mulFuncName = "Z3_OP_MUL" divFuncName = "Z3_OP_DIV" -isPrim :: Symbol -> Bool -isPrim x = S.member x prims +isPrim :: Symbol -> Bool +isPrim x = S.member x prims prims :: S.HashSet Symbol -prims = S.fromList +prims = S.fromList [ propConName , _hpropConName , vvName diff --git a/src/Language/Fixpoint/Types/PrettyPrint.hs b/src/Language/Fixpoint/Types/PrettyPrint.hs --- a/src/Language/Fixpoint/Types/PrettyPrint.hs +++ b/src/Language/Fixpoint/Types/PrettyPrint.hs @@ -13,10 +13,6 @@ import qualified Data.List as L import Language.Fixpoint.Misc import Data.Hashable -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import qualified Data.Text as T traceFix :: (Fixpoint a) => String -> a -> a @@ -100,7 +96,7 @@ instance PPrint Doc where pprintTidy _ = id -instance (PPrint a, PPrint b) => PPrint (Either a b) where +instance (PPrint a, PPrint b) => PPrint (Either a b) where pprintTidy k (Left a) = "Left" <+> pprintTidy k a pprintTidy k (Right b) = "Right" <+> pprintTidy k b diff --git a/src/Language/Fixpoint/Types/Refinements.hs b/src/Language/Fixpoint/Types/Refinements.hs --- a/src/Language/Fixpoint/Types/Refinements.hs +++ b/src/Language/Fixpoint/Types/Refinements.hs @@ -1,8 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -13,9 +10,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + -- | This module has the types for representing terms in the refinement logic. module Language.Fixpoint.Types.Refinements ( @@ -72,18 +71,21 @@ , isNonTrivial , isContraPred , isTautoPred - , isSingletonExpr + , isSingletonExpr , isSingletonReft , isFalse -- * Destructing , flattenRefas , conjuncts + , dropECst , eApps , eAppC + , eCst , exprKVars , exprSymbolsSet , splitEApp + , splitEAppThroughECst , splitPAnd , reftConjuncts , sortedReftSymbols @@ -134,7 +136,6 @@ instance NFData KVar -instance NFData SrcSpan instance NFData Subst instance NFData GradInfo instance NFData Constant @@ -149,8 +150,6 @@ -- put = B.put . M.toList -- get = M.fromList <$> B.get -instance (Eq a, Hashable a, S.Store a) => S.Store (TCEmb a) -instance S.Store SrcSpan instance S.Store KVar instance S.Store Subst instance S.Store GradInfo @@ -165,7 +164,6 @@ instance B.Binary SymConst instance B.Binary Constant instance B.Binary Bop -instance B.Binary SrcSpan instance B.Binary GradInfo instance B.Binary Brel instance B.Binary KVar @@ -176,17 +174,15 @@ put = B.put . M.toList get = M.fromList <$> B.get -instance B.Binary Subst +instance B.Binary Subst instance B.Binary Expr -instance B.Binary Reft -instance B.Binary TCArgs -instance (Eq a, Hashable a, B.Binary a) => B.Binary (TCEmb a) +instance B.Binary Reft reftConjuncts :: Reft -> [Reft] reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- ras'] where - ras' = if null ps then ks else ((conj ps) : ks) -- see [NOTE:pAnd-SLOW] + ras' = if null ps then ks else conj ps : ks -- see [NOTE:pAnd-SLOW] (ks, ps) = partition (\p -> isKvar p || isGradual p) $ refaConjuncts ra @@ -198,12 +194,12 @@ class HasGradual a where isGradual :: a -> Bool gVars :: a -> [KVar] - gVars _ = [] + gVars _ = [] ungrad :: a -> a - ungrad x = x + ungrad x = x instance HasGradual Expr where - isGradual (PGrad {}) = True + isGradual PGrad{} = True isGradual (PAnd xs) = any isGradual xs isGradual _ = False @@ -211,7 +207,7 @@ gVars (PAnd xs) = concatMap gVars xs gVars _ = [] - ungrad (PGrad {}) = PTrue + ungrad PGrad{} = PTrue ungrad (PAnd xs) = PAnd (ungrad <$> xs ) ungrad e = e @@ -247,9 +243,9 @@ instance Hashable Bop instance Hashable SymConst instance Hashable Constant -instance Hashable GradInfo -instance Hashable Subst -instance Hashable Expr +instance Hashable GradInfo +instance Hashable Subst +instance Hashable Expr instance Hashable Reft -------------------------------------------------------------------------------- @@ -285,8 +281,8 @@ -- | Uninterpreted constants that are embedded as "constant symbol : Str" -data SymConst = SL !Text - deriving (Eq, Ord, Show, Data, Typeable, Generic) +newtype SymConst = SL Text + deriving (Eq, Ord, Show, Data, Typeable, Generic) data Constant = I !Integer | R !Double @@ -321,7 +317,7 @@ | PAll ![(Symbol, Sort)] !Expr | PExist ![(Symbol, Sort)] !Expr | PGrad !KVar !Subst !GradInfo !Expr - | ECoerc !Sort !Sort !Expr + | ECoerc !Sort !Sort !Expr deriving (Eq, Show, Ord, Data, Typeable, Generic) onEverySubexpr :: (Expr -> Expr) -> Expr -> Expr @@ -440,13 +436,28 @@ go acc (EApp f e) = go (e:acc) f go acc e = (e, acc) +splitEAppThroughECst :: Expr -> (Expr, [Expr]) +splitEAppThroughECst = go [] + where + go acc (dropECst -> (EApp f e)) = go (e:acc) f + go acc e = (e, acc) + +dropECst :: Expr -> Expr +dropECst e = case e of + ECst e' _ -> dropECst e' + _ -> e + splitPAnd :: Expr -> [Expr] splitPAnd (PAnd es) = concatMap splitPAnd es splitPAnd e = [e] eAppC :: Sort -> Expr -> Expr -> Expr -eAppC s e1 e2 = ECst (EApp e1 e2) s +eAppC s e1 e2 = eCst (EApp e1 e2) s +-- | Eliminates redundant casts +eCst :: Expr -> Sort -> Expr +eCst e t = ECst (dropECst e) t + -------------------------------------------------------------------------------- debruijnIndex :: Expr -> Int debruijnIndex = go @@ -462,8 +473,8 @@ go (EIte e e1 e2) = go e + go e1 + go e2 go (ETAbs e _) = go e go (ETApp e _) = go e - go (PAnd es) = foldl (\n e -> n + go e) 0 es - go (POr es) = foldl (\n e -> n + go e) 0 es + go (PAnd es) = foldl' (\n e -> n + go e) 0 es + go (POr es) = foldl' (\n e -> n + go e) 0 es go (PNot e) = go e go (PImp e1 e2) = go e1 + go e2 go (PIff e1 e2) = go e1 + go e2 @@ -482,6 +493,8 @@ data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } deriving (Eq, Ord, Data, Typeable, Generic) +instance Hashable SortedReft + sortedReftSymbols :: SortedReft -> HashSet Symbol sortedReftSymbols sr = HashSet.union @@ -669,12 +682,6 @@ instance PPrint Bop where pprintTidy _ = toFix -instance PPrint Sort where - pprintTidy _ = toFix - -instance PPrint a => PPrint (TCEmb a) where - pprintTidy k = pprintTidy k . tceToList - instance PPrint KVar where pprintTidy _ (KV x) = text "$" <-> pprint x @@ -737,7 +744,7 @@ where zi = 1 -- RJ: DO NOT DELETE! - pprintPrec _ k (ECst e so) = parens $ pprint e <+> ":" <+> {- const (text "...") -} (pprintTidy k so) + pprintPrec _ k (ECst e so) = parens $ pprint e <+> ":" <+> {- const (text "...") -} pprintTidy k so -- pprintPrec z k (ECst e _) = pprintPrec z k e pprintPrec _ _ PTrue = trueD pprintPrec _ _ PFalse = falseD @@ -745,14 +752,14 @@ "not" <+> pprintPrec (zn+1) k p where zn = 8 pprintPrec z k (PImp p1 p2) = parensIf (z > zi) $ - (pprintPrec (zi+1) k p1) <+> + pprintPrec (zi+1) k p1 <+> "=>" <+> - (pprintPrec (zi+1) k p2) + pprintPrec (zi+1) k p2 where zi = 2 pprintPrec z k (PIff p1 p2) = parensIf (z > zi) $ - (pprintPrec (zi+1) k p1) <+> + pprintPrec (zi+1) k p1 <+> "<=>" <+> - (pprintPrec (zi+1) k p2) + pprintPrec (zi+1) k p2 where zi = 2 pprintPrec z k (PAnd ps) = parensIf (z > za) $ pprintBin (za + 1) k trueD andD ps @@ -769,7 +776,7 @@ pprintPrec _ k (PExist xts p) = pprintQuant k "exists" xts p pprintPrec _ k (ELam (x,t) e) = "lam" <+> toFix x <+> ":" <+> toFix t <+> text "." <+> pprintTidy k e pprintPrec _ k (ECoerc a t e) = parens $ "coerce" <+> toFix a <+> "~" <+> toFix t <+> text "in" <+> pprintTidy k e - pprintPrec _ _ p@(PKVar {}) = toFix p + pprintPrec _ _ p@PKVar{} = toFix p pprintPrec _ _ (ETApp e s) = "ETApp" <+> toFix e <+> toFix s pprintPrec _ _ (ETAbs e s) = "ETAbs" <+> toFix e <+> toFix s pprintPrec z k (PGrad x _ _ e) = pprintPrec z k e <+> "&&" <+> toFix x -- "??" @@ -862,7 +869,7 @@ isSingletonExpr v (PAtom r e1 e2) | e1 == EVar v && isEq r = Just e2 | e2 == EVar v && isEq r = Just e1 -isSingletonExpr v (PIff e1 e2) +isSingletonExpr v (PIff e1 e2) | e1 == EVar v = Just e2 | e2 == EVar v = Just e1 isSingletonExpr _ _ = Nothing @@ -885,14 +892,16 @@ pOr = simplify . POr +infixl 9 &.& (&.&) :: Pred -> Pred -> Pred (&.&) p q = pAnd [p, q] +infixl 9 |.| (|.|) :: Pred -> Pred -> Pred (|.|) p q = pOr [p, q] pIte :: Pred -> Expr -> Expr -> Expr -pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3] +pIte p1 p2 p3 = pAnd [p1 `PImp` p2, PNot p1 `PImp` p3] pExist :: [(Symbol, Sort)] -> Pred -> Pred pExist [] p = p @@ -948,7 +957,7 @@ -- | Gradual Type Manipulation ---------------------------- ------------------------------------------------------------ pGAnds :: [Expr] -> Expr -pGAnds = foldl pGAnd PTrue +pGAnds = foldl' pGAnd PTrue pGAnd :: Expr -> Expr -> Expr pGAnd (PGrad k su i p) q = PGrad k su i (pAnd [p, q]) @@ -1039,3 +1048,6 @@ toReft :: r -> Reft ofReft :: Reft -> r params :: r -> [Symbol] -- ^ parameters for Reft, vv + others + +instance Fixpoint Doc where + toFix = id diff --git a/src/Language/Fixpoint/Types/Solutions.hs b/src/Language/Fixpoint/Types/Solutions.hs --- a/src/Language/Fixpoint/Types/Solutions.hs +++ b/src/Language/Fixpoint/Types/Solutions.hs @@ -15,6 +15,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the top-level SOLUTION data types, -- including various indices used for solving. @@ -75,19 +77,15 @@ import GHC.Generics import Control.DeepSeq import Data.Hashable -import qualified Data.Maybe as Mb +import qualified Data.Maybe as Mb import qualified Data.HashMap.Strict as M import qualified Data.List as L import Data.Generics (Data) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Data.Typeable (Typeable) import Control.Monad (filterM) import Language.Fixpoint.Misc import Language.Fixpoint.Types.PrettyPrint -import Language.Fixpoint.Types.Spans +import Language.Fixpoint.Types.Spans import Language.Fixpoint.Types.Names import Language.Fixpoint.Types.Sorts import Language.Fixpoint.Types.Theories @@ -140,7 +138,7 @@ emptyGMap sol = mapGMap sol (\(x,_) -> (x, GB [])) updateGMapWithKey :: [(KVar, QBind)] -> GSolution -> GSolution -updateGMapWithKey kqs sol = sol {gMap = foldl (\m (k, (QB eq)) -> M.adjust (\(x, GB eqs) -> (x, GB (if eq `elem` eqs then eqs else eq:eqs))) k m) (gMap sol) kqs } +updateGMapWithKey kqs sol = sol {gMap = L.foldl' (\m (k, QB eq) -> M.adjust (\(x, GB eqs) -> (x, GB (if eq `elem` eqs then eqs else eq:eqs))) k m) (gMap sol) kqs } qb :: [EQual] -> QBind qb = QB @@ -181,8 +179,8 @@ -------------------------------------------------------------------------------- -- | An `EbindSol` contains the relevant information for an existential-binder; --- (See tests/pos/ebind-*.fq for examples.) This is either --- 1. the constraint whose HEAD is a singleton that defines the binder, OR +-- (See tests/pos/ebind-*.fq for examples.) This is either +-- 1. the constraint whose HEAD is a singleton that defines the binder, OR -- 2. the solved out TERM that we should use in place of the ebind at USES. -------------------------------------------------------------------------------- data EbindSol @@ -192,19 +190,19 @@ | EbIncr -- ^ EBinds not to be solved for (because they're currently being solved for) deriving (Show, Generic, NFData) -instance PPrint EbindSol where +instance PPrint EbindSol where pprintTidy k (EbDef i x) = "EbDef:" <+> pprintTidy k i <+> pprintTidy k x pprintTidy k (EbSol e) = "EbSol:" <+> pprintTidy k e - pprintTidy _ (EbIncr) = "EbIncr" + pprintTidy _ EbIncr = "EbIncr" -------------------------------------------------------------------------------- -updateEbind :: Sol a b -> BindId -> Pred -> Sol a b +updateEbind :: Sol a b -> BindId -> Pred -> Sol a b -------------------------------------------------------------------------------- -updateEbind s i !e = case M.lookup i (sEbd s) of +updateEbind s i !e = case M.lookup i (sEbd s) of Nothing -> errorstar $ "updateEBind: Unknown ebind " ++ show i - Just (EbSol e0) -> errorstar $ "updateEBind: Re-assigning ebind " ++ show i ++ " with solution: " ++ show e0 + Just (EbSol e0) -> errorstar $ "updateEBind: Re-assigning ebind " ++ show i ++ " with solution: " ++ show e0 Just _ -> s { sEbd = M.insert i (EbSol e) (sEbd s) } - + -------------------------------------------------------------------------------- -- | A `Sol` contains the various indices needed to compute a solution, -- in particular, to compute `lhsPred` for any given constraint. @@ -228,21 +226,21 @@ mapGMap sol f = sol {gMap = M.map f (gMap sol)} instance Semigroup (Sol a b) where - s1 <> s2 = Sol { sEnv = (sEnv s1) <> (sEnv s2) - , sMap = (sMap s1) <> (sMap s2) - , gMap = (gMap s1) <> (gMap s2) - , sHyp = (sHyp s1) <> (sHyp s2) - , sScp = (sScp s1) <> (sScp s2) - , sEbd = (sEbd s1) <> (sEbd s2) - , sxEnv = (sxEnv s1) <> (sxEnv s2) + s1 <> s2 = Sol { sEnv = sEnv s1 <> sEnv s2 + , sMap = sMap s1 <> sMap s2 + , gMap = gMap s1 <> gMap s2 + , sHyp = sHyp s1 <> sHyp s2 + , sScp = sScp s1 <> sScp s2 + , sEbd = sEbd s1 <> sEbd s2 + , sxEnv = sxEnv s1 <> sxEnv s2 } instance Monoid (Sol a b) where - mempty = Sol { sEnv = mempty - , sMap = mempty - , gMap = mempty - , sHyp = mempty - , sScp = mempty + mempty = Sol { sEnv = mempty + , sMap = mempty + , gMap = mempty + , sHyp = mempty + , sScp = mempty , sEbd = mempty , sxEnv = mempty } @@ -253,7 +251,7 @@ instance (PPrint a, PPrint b) => PPrint (Sol a b) where pprintTidy k s = vcat [ "sMap :=" <+> pprintTidy k (sMap s) - , "sEbd :=" <+> pprintTidy k (sEbd s) + , "sEbd :=" <+> pprintTidy k (sEbd s) ] -------------------------------------------------------------------------------- @@ -276,7 +274,7 @@ -------------------------------------------------------------------------------- result :: Sol a QBind -> M.HashMap KVar Expr -------------------------------------------------------------------------------- -result s = sMap $ (pAnd . fmap eqPred . qbEQuals) <$> s +result s = sMap $ pAnd . fmap eqPred . qbEQuals <$> s -------------------------------------------------------------------------------- @@ -291,11 +289,11 @@ -------------------------------------------------------------------------------- -- | Create a Solution --------------------------------------------------------- -------------------------------------------------------------------------------- -fromList :: SymEnv - -> [(KVar, a)] - -> [(KVar, b)] - -> [(KVar, Hyp)] - -> M.HashMap KVar IBindEnv +fromList :: SymEnv + -> [(KVar, a)] + -> [(KVar, b)] + -> [(KVar, Hyp)] + -> M.HashMap KVar IBindEnv -> [(BindId, EbindSol)] -> SEnv (BindId, Sort) -> Sol a b @@ -312,9 +310,9 @@ -------------------------------------------------------------------------------- qbPreds msg s su (QB eqs) = [ (elabPred eq, eq) | eq <- eqs ] where - elabPred eq = elaborate (atLoc eq $ "qbPreds:" ++ msg) env - . subst su - . eqPred + elabPred eq = elaborate (atLoc eq $ "qbPreds:" ++ msg) env + . subst su + . eqPred $ eq env = sEnv s @@ -379,8 +377,8 @@ , _eqArgs :: ![Expr] } deriving (Eq, Show, Data, Typeable, Generic) -instance Loc EQual where - srcSpan = srcSpan . eqQual +instance Loc EQual where + srcSpan = srcSpan . eqQual trueEqual :: EQual trueEqual = EQL trueQual mempty [] diff --git a/src/Language/Fixpoint/Types/Sorts.hs b/src/Language/Fixpoint/Types/Sorts.hs --- a/src/Language/Fixpoint/Types/Sorts.hs +++ b/src/Language/Fixpoint/Types/Sorts.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -11,7 +10,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the data types, operations and -- serialization functions for representing Fixpoint's -- implication (i.e. subtyping) and well-formedness @@ -73,10 +75,10 @@ -- * Embedding Source types as Sorts , TCEmb, TCArgs (..) - , tceLookup - , tceFromList + , tceLookup + , tceFromList , tceToList - , tceMember + , tceMember , tceInsert , tceInsertWith , tceMap @@ -86,11 +88,6 @@ import Data.Generics (Data) import Data.Typeable (Typeable) import GHC.Generics (Generic) - -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Data.Hashable import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet @@ -234,24 +231,24 @@ go vs ss t = (reverse vs, reverse ss, t) -sortAbs :: Sort -> Int -sortAbs (FAbs i s) = max i (sortAbs s) -sortAbs (FFunc s1 s2) = max (sortAbs s1) (sortAbs s2) +sortAbs :: Sort -> Int +sortAbs (FAbs i s) = max i (sortAbs s) +sortAbs (FFunc s1 s2) = max (sortAbs s1) (sortAbs s2) sortAbs (FApp s1 s2) = max (sortAbs s1) (sortAbs s2) -sortAbs _ = -1 +sortAbs _ = -1 -mapFVar :: (Int -> Int) -> Sort -> Sort -mapFVar f = go +mapFVar :: (Int -> Int) -> Sort -> Sort +mapFVar f = go where go (FVar i) = FVar (f i) go (FAbs i t) = FAbs (f i) (go t) go (FFunc t1 t2) = FFunc (go t1) (go t2) go (FApp t1 t2) = FApp (go t1) (go t2) - go t@(FObj _) = t - go t@(FTC _) = t - go t@FInt = t - go t@FReal = t - go t@FNum = t - go t@FFrac = t + go t@(FObj _) = t + go t@(FTC _) = t + go t@FInt = t + go t@FReal = t + go t@FNum = t + go t@FFrac = t -------------------------------------------------------------------------------- -- | Sorts --------------------------------------------------------------------- @@ -268,6 +265,9 @@ | FApp !Sort !Sort -- ^ constructed type deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance PPrint Sort where + pprintTidy _ = toFix + sortSymbols :: Sort -> HashSet Symbol sortSymbols = \case FObj s -> HashSet.singleton s @@ -317,7 +317,7 @@ muSort dds = mapSortDataDecl tx <$> dds where selfs = [(fTyconSelfSort c n, fTyconSort c) | DDecl c n _ <- dds] - tx t = fromMaybe t $ L.lookup t selfs + tx t = fromMaybe t $ L.lookup t selfs mapSortDataDecl f dd = dd { ddCtors = mapSortDataCTor f <$> ddCtors dd } mapSortDataCTor f ct = ct { dcFields = mapSortDataField f <$> dcFields ct } @@ -352,7 +352,7 @@ isString :: Sort -> Bool isString (FApp l c) = (isList l && isChar c) || isString l -isString (FTC (TC c i)) = (val c == strConName || tc_isString i) +isString (FTC (TC c i)) = val c == strConName || tc_isString i isString (FAbs _ s) = isString s isString _ = False @@ -374,7 +374,7 @@ go (i:is) ss = FAbs i $ go is ss go _ _ = error "cannot happen" - -- foldl (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1] + -- foldl' (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1] bkFFunc :: Sort -> Maybe (Int, [Sort]) bkFFunc t = (maximum (0 : as),) <$> bkFun t' @@ -399,8 +399,8 @@ isPoly FAbs {} = True isPoly _ = False -mkPoly :: Int -> Sort -> Sort -mkPoly i s = foldl (flip FAbs) s [0..i] +mkPoly :: Int -> Sort -> Sort +mkPoly i s = foldl' (flip FAbs) s [0..i] instance Hashable FTycon where @@ -429,11 +429,12 @@ toFixSort t@(FApp _ _) = toFixFApp (unFApp t) toFixAbsApp :: Sort -> Doc -toFixAbsApp t = text "func" <-> parens (toFix n <+> text "," <+> toFix ts) +toFixAbsApp (functionSort -> Just (vs, ss, s)) = + text "func" <-> parens (toFix n <+> text "," <+> toFix ts) where - Just (vs, ss, s) = functionSort t n = length vs ts = ss ++ [s] +toFixAbsApp _ = error "Unexpected nothing function sort" toFixFApp :: ListNE Sort -> Doc toFixFApp [t] = toFixSort t @@ -501,9 +502,9 @@ | otherwise = FTC c basicSorts :: [Sort] -basicSorts = [FInt, boolSort] +basicSorts = [FInt, boolSort] -type SortSubst = M.HashMap Symbol Sort +type SortSubst = M.HashMap Symbol Sort mkSortSubst :: [(Symbol, Sort)] -> SortSubst mkSortSubst = M.fromList @@ -517,8 +518,8 @@ sortSubst θ (FAbs i t) = FAbs i (sortSubst θ t) sortSubst _ t = t --- instance (S.Store a) => S.Store (TCEmb a) -instance S.Store TCArgs +-- instance (S.Store a) => S.Store (TCEmb a) +instance S.Store TCArgs instance S.Store FTycon instance S.Store TCInfo instance S.Store Sort @@ -531,12 +532,13 @@ instance B.Binary TCInfo instance B.Binary FTycon instance B.Binary Sort +instance (Eq a, Hashable a, B.Binary (M.HashMap a (Sort, TCArgs))) => B.Binary (TCEmb a) instance NFData FTycon where rnf (TC x i) = x `seq` i `seq` () -instance (NFData a) => NFData (TCEmb a) -instance NFData TCArgs +instance (NFData a) => NFData (TCEmb a) +instance NFData TCArgs instance NFData TCInfo instance NFData Sort instance NFData DataField @@ -556,57 +558,61 @@ mappend = (<>) ------------------------------------------------------------------------------- --- | Embedding stuff as Sorts +-- | Embedding stuff as Sorts ------------------------------------------------------------------------------- -newtype TCEmb a = TCE (M.HashMap a (Sort, TCArgs)) - deriving (Eq, Show, Data, Typeable, Generic) +newtype TCEmb a = TCE (M.HashMap a (Sort, TCArgs)) + deriving (Eq, Show, Data, Typeable, Generic) instance Hashable a => Hashable (TCEmb a) +instance PPrint a => PPrint (TCEmb a) where + pprintTidy k = pprintTidy k . tceToList -data TCArgs = WithArgs | NoArgs - deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance Hashable TCArgs +data TCArgs = WithArgs | NoArgs + deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance Hashable TCArgs +instance B.Binary TCArgs + tceInsertWith :: (Eq a, Hashable a) => (Sort -> Sort -> Sort) -> a -> Sort -> TCArgs -> TCEmb a -> TCEmb a tceInsertWith f k t a (TCE m) = TCE (M.insertWith ff k (t, a) m) - where + where ff (t1, a1) (t2, a2) = (f t1 t2, a1 <> a2) -instance Semigroup TCArgs where +instance Semigroup TCArgs where NoArgs <> NoArgs = NoArgs _ <> _ = WithArgs -instance Monoid TCArgs where - mempty = NoArgs +instance Monoid TCArgs where + mempty = NoArgs mappend = (<>) -instance PPrint TCArgs where +instance PPrint TCArgs where pprintTidy _ WithArgs = "*" pprintTidy _ NoArgs = "" tceInsert :: (Eq a, Hashable a) => a -> Sort -> TCArgs -> TCEmb a -> TCEmb a tceInsert k t a (TCE m) = TCE (M.insert k (t, a) m) -tceLookup :: (Eq a, Hashable a) => a -> TCEmb a -> Maybe (Sort, TCArgs) +tceLookup :: (Eq a, Hashable a) => a -> TCEmb a -> Maybe (Sort, TCArgs) tceLookup k (TCE m) = M.lookup k m -instance (Eq a, Hashable a) => Semigroup (TCEmb a) where +instance (Eq a, Hashable a) => Semigroup (TCEmb a) where (TCE m1) <> (TCE m2) = TCE (m1 <> m2) -instance (Eq a, Hashable a) => Monoid (TCEmb a) where - mempty = TCE mempty +instance (Eq a, Hashable a) => Monoid (TCEmb a) where + mempty = TCE mempty mappend = (<>) tceMap :: (Eq b, Hashable b) => (a -> b) -> TCEmb a -> TCEmb b -tceMap f = tceFromList . fmap (mapFst f) . tceToList +tceMap f = tceFromList . fmap (mapFst f) . tceToList tceFromList :: (Eq a, Hashable a) => [(a, (Sort, TCArgs))] -> TCEmb a -tceFromList = TCE . M.fromList +tceFromList = TCE . M.fromList tceToList :: TCEmb a -> [(a, (Sort, TCArgs))] tceToList (TCE m) = M.toList m -tceMember :: (Eq a, Hashable a) => a -> TCEmb a -> Bool +tceMember :: (Eq a, Hashable a) => a -> TCEmb a -> Bool tceMember k (TCE m) = M.member k m diff --git a/src/Language/Fixpoint/Types/Spans.hs b/src/Language/Fixpoint/Types/Spans.hs --- a/src/Language/Fixpoint/Types/Spans.hs +++ b/src/Language/Fixpoint/Types/Spans.hs @@ -4,6 +4,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Language.Fixpoint.Types.Spans ( -- * Concrete Location Type @@ -34,7 +36,7 @@ -- * Destructing spans , sourcePosElts - , srcLine + , srcLine ) where -- import Control.Exception @@ -153,7 +155,7 @@ ppSourcePos :: SourcePos -> Doc ppSourcePos z = text (printf "%s:%d:%d" f l c) where - (f,l,c) = sourcePosElts $ z + (f,l,c) = sourcePosElts z instance Fixpoint SourcePos where toFix = text . show @@ -224,7 +226,10 @@ , sp_stop :: !SourcePos} deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance NFData SrcSpan +instance S.Store SrcSpan instance Serialize SrcSpan +instance B.Binary SrcSpan instance PPrint SrcSpan where pprintTidy _ = ppSrcSpan @@ -246,13 +251,13 @@ instance Hashable SrcSpan where hashWithSalt i z = hashWithSalt i (sp_start z, sp_stop z) -instance Loc SrcSpan where - srcSpan x = x +instance Loc SrcSpan where + srcSpan x = x instance Loc () where srcSpan _ = dummySpan -instance Loc SourcePos where +instance Loc SourcePos where srcSpan l = SS l l dummySpan :: SrcSpan diff --git a/src/Language/Fixpoint/Types/Substitutions.hs b/src/Language/Fixpoint/Types/Substitutions.hs --- a/src/Language/Fixpoint/Types/Substitutions.hs +++ b/src/Language/Fixpoint/Types/Substitutions.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + -- | This module contains the various instances for Subable, -- which (should) depend on the visitors, and hence cannot -- be in the same place as the @Term@ definitions. - -{-# LANGUAGE FlexibleInstances #-} module Language.Fixpoint.Types.Substitutions ( mkSubst , isEmptySubst @@ -20,10 +21,6 @@ import Data.Maybe import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Language.Fixpoint.Types.PrettyPrint import Language.Fixpoint.Types.Names import Language.Fixpoint.Types.Sorts @@ -63,7 +60,7 @@ targetSubstSyms (Su ms) = syms $ M.elems ms - + instance Subable () where syms _ = [] subst _ () = () @@ -88,7 +85,7 @@ substf = fmap . substf substa = fmap . substa - + instance Subable a => Subable (M.HashMap k a) where syms = syms . M.elems subst = M.map . subst @@ -274,6 +271,7 @@ toFix (RR so (Reft (v, ra))) = braces $ toFix v <+> text ":" <+> toFix so <+> text "|" <+> toFix (conjuncts ra) + simplify (RR so (Reft (v, ra))) = RR (simplify so) (Reft (simplify v, simplify ra)) instance Show Reft where show = showFix diff --git a/src/Language/Fixpoint/Types/Templates.hs b/src/Language/Fixpoint/Types/Templates.hs --- a/src/Language/Fixpoint/Types/Templates.hs +++ b/src/Language/Fixpoint/Types/Templates.hs @@ -1,6 +1,6 @@ module Language.Fixpoint.Types.Templates ( - anything, Templates, makeTemplates, + anything, Templates, makeTemplates, isEmptyTemplates, isAnyTemplates, @@ -13,94 +13,94 @@ import Language.Fixpoint.Types.PrettyPrint import Text.PrettyPrint.HughesPJ.Compat -data Templates - = TAll - | TExprs [Template] +data Templates + = TAll + | TExprs [Template] deriving Show type Template = ([Symbol], Expr) -class HasTemplates a where - filterUnMatched :: Templates -> a -> a +class HasTemplates a where + filterUnMatched :: Templates -> a -> a instance HasTemplates Expr where - filterUnMatched temps e = pAnd $ filter (not . matchesTemplates temps) $ conjuncts e + filterUnMatched temps e = pAnd $ filter (not . matchesTemplates temps) $ conjuncts e instance HasTemplates Reft where filterUnMatched temps (Reft (x,e)) = Reft (x, filterUnMatched temps e) -matchesTemplates :: Templates -> Expr -> Bool -matchesTemplates TAll _ = True +matchesTemplates :: Templates -> Expr -> Bool +matchesTemplates TAll _ = True matchesTemplates (TExprs ts) e = any (`matchesTemplate` e) ts -matchesTemplate :: Template -> Expr -> Bool +matchesTemplate :: Template -> Expr -> Bool matchesTemplate (xs, t@(EVar x)) e - = x `elem` xs || e == t -matchesTemplate (xs, EApp t1 t2) (EApp e1 e2) - = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, ENeg t) (ENeg e) + = x `elem` xs || e == t +matchesTemplate (xs, EApp t1 t2) (EApp e1 e2) + = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, ENeg t) (ENeg e) = matchesTemplate (xs, t) e -matchesTemplate (xs, EBin b t1 t2) (EBin b' e1 e2) - = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, EIte t1 t2 t3) (EIte e1 e2 e3) - = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 && matchesTemplate (xs, t3) e3 -matchesTemplate (xs, ECst t s) (ECst e s') +matchesTemplate (xs, EBin b t1 t2) (EBin b' e1 e2) + = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, EIte t1 t2 t3) (EIte e1 e2 e3) + = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 && matchesTemplate (xs, t3) e3 +matchesTemplate (xs, ECst t s) (ECst e s') = s == s' && matchesTemplate (xs, t) e -matchesTemplate (xs, ELam b t) (ELam b' e) +matchesTemplate (xs, ELam b t) (ELam b' e) = b == b' && matchesTemplate (xs, t) e -matchesTemplate (xs, ETApp t s) (ETApp e s') +matchesTemplate (xs, ETApp t s) (ETApp e s') = s == s' && matchesTemplate (xs, t) e -matchesTemplate (xs, ETAbs t s) (ETAbs e s') +matchesTemplate (xs, ETAbs t s) (ETAbs e s') = s == s' && matchesTemplate (xs, t) e -matchesTemplate (xs, PNot t) (PNot e) +matchesTemplate (xs, PNot t) (PNot e) = matchesTemplate (xs, t) e -matchesTemplate (xs, PAnd ts) (PAnd es) - = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es -matchesTemplate (xs, POr ts) (POr es) - = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es -matchesTemplate (xs, PImp t1 t2) (PImp e1 e2) - = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, PIff t1 t2) (PIff e1 e2) - = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, PAtom b t1 t2) (PAtom b' e1 e2) - = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 -matchesTemplate (xs, PAll s t) (PAll s' e) +matchesTemplate (xs, PAnd ts) (PAnd es) + = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es +matchesTemplate (xs, POr ts) (POr es) + = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es +matchesTemplate (xs, PImp t1 t2) (PImp e1 e2) + = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, PIff t1 t2) (PIff e1 e2) + = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, PAtom b t1 t2) (PAtom b' e1 e2) + = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, PAll s t) (PAll s' e) = s == s' && matchesTemplate (xs, t) e -matchesTemplate (xs, PExist s t) (PExist s' e) +matchesTemplate (xs, PExist s t) (PExist s' e) = s == s' && matchesTemplate (xs, t) e -matchesTemplate (xs, PGrad s1 s2 s3 t) (PGrad s1' s2' s3' e) +matchesTemplate (xs, PGrad s1 s2 s3 t) (PGrad s1' s2' s3' e) = s1 == s1' && s2 == s2' && s3 == s3' && matchesTemplate (xs, t) e -matchesTemplate (xs, ECoerc s1 s2 t) (ECoerc s1' s2' e) +matchesTemplate (xs, ECoerc s1 s2 t) (ECoerc s1' s2' e) = s1 == s1' && s2 == s2' && matchesTemplate (xs, t) e -matchesTemplate (_, t) e - = t == e +matchesTemplate (_, t) e + = t == e makeTemplates :: [([Symbol], Expr)] -> Templates -makeTemplates = TExprs +makeTemplates = TExprs -isEmptyTemplates, isAnyTemplates :: Templates -> Bool -isEmptyTemplates (TExprs []) = True -isEmptyTemplates _ = False +isEmptyTemplates, isAnyTemplates :: Templates -> Bool +isEmptyTemplates (TExprs []) = True +isEmptyTemplates _ = False -isAnyTemplates TAll = True -isAnyTemplates _ = False +isAnyTemplates TAll = True +isAnyTemplates _ = False anything :: Templates anything = TAll -instance Semigroup Templates where +instance Semigroup Templates where TAll <> _ = TAll _ <> TAll = TAll TExprs i1 <> TExprs i2 = TExprs (i1 ++ i2) -instance Monoid Templates where - mempty = TExprs [] +instance Monoid Templates where + mempty = TExprs [] instance PPrint Templates where - pprintTidy _ = text . show + pprintTidy _ = text . show diff --git a/src/Language/Fixpoint/Types/Theories.hs b/src/Language/Fixpoint/Types/Theories.hs --- a/src/Language/Fixpoint/Types/Theories.hs +++ b/src/Language/Fixpoint/Types/Theories.hs @@ -4,6 +4,9 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | This module contains the types defining an SMTLIB2 interface. module Language.Fixpoint.Types.Theories ( @@ -35,10 +38,6 @@ import Data.Generics (Data) -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Data.Typeable (Typeable) import Data.Hashable import GHC.Generics (Generic) @@ -50,13 +49,13 @@ import Language.Fixpoint.Types.Environments import Text.PrettyPrint.HughesPJ.Compat -import qualified Data.List as L +import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import qualified Data.Store as S import qualified Data.HashMap.Strict as M -import qualified Language.Fixpoint.Misc as Misc +import qualified Language.Fixpoint.Misc as Misc import Data.Functor.Contravariant (Contravariant(contramap)) -------------------------------------------------------------------------------- @@ -65,7 +64,7 @@ type Raw = LT.Text instance S.Store Raw where - peek = LT.fromStrict <$> S.peek + peek = LT.fromStrict <$> S.peek poke = S.poke . LT.toStrict size = contramap LT.toStrict S.size @@ -106,13 +105,13 @@ xEnv' = unionSEnv xEnv wiredInEnv dEnv = fromListSEnv [(symbol d, d) | d <- ds] sortMap = M.fromList (zip smts [0..]) - smts = funcSorts dEnv ts + smts = funcSorts dEnv ts -- | These are "BUILT-in" polymorphic functions which are -- UNININTERPRETED but POLYMORPHIC, hence need to go through -- the apply-defunc stuff. wiredInEnv :: M.HashMap Symbol Sort -wiredInEnv = M.fromList +wiredInEnv = M.fromList [ (toIntName, mkFFunc 1 [FVar 0, FInt]) , (tyCastName, FAbs 0 $ FAbs 1 $ FFunc (FVar 0) (FVar 1)) ] @@ -158,7 +157,7 @@ insertSymEnv x t env = env { seSort = insertSEnv x t (seSort env) } insertsSymEnv :: SymEnv -> [(Symbol, Sort)] -> SymEnv -insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env) +insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env) symbolAtName :: (PPrint a) => Symbol -> SymEnv -> a -> Sort -> Text symbolAtName mkSym env e = symbolAtSmtName mkSym env e . ffuncSort env @@ -178,7 +177,7 @@ ffuncSort :: SymEnv -> Sort -> FuncSort ffuncSort env t = {- tracepp ("ffuncSort " ++ showpp (t1,t2)) -} (tx t1, tx t2) where - tx = applySmtSort (seData env) + tx = applySmtSort (seData env) (t1, t2) = args t args (FFunc a b) = (a, b) args _ = (FInt, FInt) @@ -254,21 +253,22 @@ -- using `Int` (though really, there SHOULD BE NO floating tyVars... -- 'smtSort True msg t' serializes a sort 't' using type variables, -- 'smtSort False msg t' serializes a sort 't' using 'Int' instead of tyvars. - sortSmtSort :: Bool -> SEnv DataDecl -> Sort -> SmtSort sortSmtSort poly env t = {- tracepp ("sortSmtSort: " ++ showpp t) else id) $ -} go . unAbs $ t where - m = sortAbs t + m = sortAbs t go (FFunc _ _) = SInt go FInt = SInt go FReal = SReal go t | t == boolSort = SBool - | isString t = SString + | isString t = SString go (FVar i) | poly, i < m = SVar i | otherwise = SInt - go t = fappSmtSort poly m env ct ts where (ct:ts) = unFApp t + go t + | (ct:ts) <- unFApp t = fappSmtSort poly m env ct ts + | otherwise = error "Unexpected empty 'unFApp t'" fappSmtSort :: Bool -> Int -> SEnv DataDecl -> Sort -> [Sort] -> SmtSort fappSmtSort poly m env = go diff --git a/src/Language/Fixpoint/Types/Triggers.hs b/src/Language/Fixpoint/Types/Triggers.hs --- a/src/Language/Fixpoint/Types/Triggers.hs +++ b/src/Language/Fixpoint/Types/Triggers.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -18,7 +17,7 @@ import Text.PrettyPrint.HughesPJ import Language.Fixpoint.Types.Refinements -import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.PrettyPrint import Language.Fixpoint.Misc (errorstar) @@ -28,10 +27,10 @@ data Trigger = NoTrigger | LeftHandSide deriving (Eq, Show, Generic) -instance PPrint Trigger where - pprintTidy _ = text . show +instance PPrint Trigger where + pprintTidy _ = text . show -instance PPrint a => PPrint (Triggered a) where +instance PPrint a => PPrint (Triggered a) where pprintTidy k (TR t x) = parens (pprintTidy k t <+> text ":" <+> pprintTidy k x) noTrigger :: e -> Triggered e diff --git a/src/Language/Fixpoint/Types/Utils.hs b/src/Language/Fixpoint/Types/Utils.hs --- a/src/Language/Fixpoint/Types/Utils.hs +++ b/src/Language/Fixpoint/Types/Utils.hs @@ -35,7 +35,7 @@ -------------------------------------------------------------------------------- kvarDomain si k = domain (bs si) (getWfC si k) -domain :: BindEnv -> WfC a -> [Symbol] +domain :: BindEnv a -> WfC a -> [Symbol] domain be wfc = fst3 (wrft wfc) : map fst (envCs be $ wenv wfc) getWfC :: SInfo a -> KVar -> WfC a @@ -58,9 +58,9 @@ rs = reftConjuncts (sr_reft sr) t = sr_sort sr - go ps ks gs ((v, PKVar k su ):xs) = go ps (KVS v t k su:ks) gs xs - go ps ks gs ((v, PGrad k su _ _):xs) = go ps ks (KVS v t k su:gs) xs - go ps ks gs ((_, p):xs) = go (p:ps) ks gs xs + go ps ks gs ((v, PKVar k su ):xs) = go ps (KVS v t k su:ks) gs xs + go ps ks gs ((v, PGrad k su _ _):xs) = go ps ks (KVS v t k su:gs) xs + go ps ks gs ((_, p):xs) = go (p:ps) ks gs xs go ps ks gs [] = (ps, ks, gs) @@ -78,17 +78,17 @@ ------------------------------------------------------------------------------- isRegular [] = error "impossible: isRegular" -isRegular ds@(d:_) = all (\d' -> ddVars d' == nArgs) ds -- same number of tyArgs +isRegular ds@(d:_) = all (\d' -> ddVars d' == nArgs) ds -- same number of tyArgs && all isRegApp fldSortApps -- 'regular' application (tc @0 ... @n) where nArgs = ddVars d tcs = S.fromList ( symbol . ddTyCon <$> ds) - fldSortApps = [ (c,ts) | d <- ds - , ctor <- ddCtors d - , DField _ t <- dcFields ctor + fldSortApps = [ (c,ts) | d' <- ds + , ctor <- ddCtors d' + , DField _ t <- dcFields ctor , (c, ts) <- sortApps t - ] - isRegApp cts = case cts of + ] + isRegApp cts = case cts of (FTC c, ts) -> not (S.member (symbol c) tcs) || isRegularArgs nArgs ts _ -> False @@ -98,17 +98,17 @@ type SortApp = (Sort, [Sort]) sortApps :: Sort -> [SortApp] -sortApps = go - where +sortApps = go + where go t@FApp {} = (f, ts) : concatMap go ts where (f, ts) = splitApp t go (FFunc t1 t2) = go t1 ++ go t2 go (FAbs _ t) = go t go _ = [] -splitApp :: Sort -> SortApp +splitApp :: Sort -> SortApp splitApp = go [] where - go stk (FApp t1 t2) = go (t2:stk) t1 + go stk (FApp t1 t2) = go (t2:stk) t1 go stk t = (t, stk) -------------------------------------------------------------------------------- @@ -140,5 +140,5 @@ go (FTC c) = [c] go (FApp t1 t2) = go t1 ++ go t2 go (FFunc t1 t2) = go t1 ++ go t2 - go (FAbs _ t) = go t + go (FAbs _ t) = go t go _ = [] diff --git a/src/Language/Fixpoint/Types/Visitor.hs b/src/Language/Fixpoint/Types/Visitor.hs --- a/src/Language/Fixpoint/Types/Visitor.hs +++ b/src/Language/Fixpoint/Types/Visitor.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + module Language.Fixpoint.Types.Visitor ( -- * Visitor Visitor (..) @@ -45,18 +45,10 @@ , foldSort , mapSort , foldDataDecl - - , (<$$>) - - ) where -- import Control.Monad.Trans.State.Strict (State, modify, runState) -- import Control.DeepSeq -#if !MIN_VERSION_base(4,14,0) -import Data.Semigroup (Semigroup (..)) -#endif - import Control.Monad.State.Strict import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M @@ -106,17 +98,6 @@ -- !cur <- get -- put ((mappend $!! z) $!! cur) -(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b] -f <$$> xs = f Misc.<$$> xs - --- (<$$>) :: (Applicative f) => (a -> f b) -> [a] -> f [b] --- f <$$> x = traverse f x --- _ <$$> [] = return [] --- f <$$> (x:xs) = do - -- !y <- f x - -- !ys <- f <$$> xs - -- return (y:ys) ------------------------------------------------------------------------------- class Visitable t where visit :: (Monoid a) => Visitor a c -> c -> t -> VisitM a t @@ -129,10 +110,10 @@ instance Visitable SortedReft where visit v c (RR t r) = RR t <$> visit v c r -instance Visitable (Symbol, SortedReft) where - visit v c (sym, sr) = (sym, ) <$> visit v c sr +instance Visitable (Symbol, SortedReft, a) where + visit v c (sym, sr, a) = (sym, ,a) <$> visit v c sr -instance Visitable BindEnv where +instance Visitable (BindEnv a) where visit v c = mapM (visit v c) --------------------------------------------------------------------------------- @@ -153,56 +134,56 @@ visit v c x = do cm' <- mapM (visit v c) (cm x) bs' <- visit v c (bs x) - ae' <- visit v c (ae x) + ae' <- visit v c (ae x) return x { cm = cm', bs = bs', ae = ae' } -instance Visitable AxiomEnv where - visit v c x = do - eqs' <- mapM (visit v c) (aenvEqs x) - simpls' <- mapM (visit v c) (aenvSimpl x) - return x { aenvEqs = eqs' , aenvSimpl = simpls'} +instance Visitable AxiomEnv where + visit v c x = do + eqs' <- mapM (visit v c) (aenvEqs x) + simpls' <- mapM (visit v c) (aenvSimpl x) + return x { aenvEqs = eqs' , aenvSimpl = simpls'} -instance Visitable Equation where - visit v c eq = do - body' <- visit v c (eqBody eq) - return eq { eqBody = body' } +instance Visitable Equation where + visit v c eq = do + body' <- visit v c (eqBody eq) + return eq { eqBody = body' } -instance Visitable Rewrite where - visit v c rw = do - body' <- visit v c (smBody rw) - return rw { smBody = body' } +instance Visitable Rewrite where + visit v c rw = do + body' <- visit v c (smBody rw) + return rw { smBody = body' } --------------------------------------------------------------------------------- visitExpr :: (Monoid a) => Visitor a ctx -> ctx -> Expr -> VisitM a Expr visitExpr !v = vE where - vE !c !e = do {- SCC "visitExpr.vE.accum" #-} accum acc - {- SCC "visitExpr.vE.step" #-} step c' e' + vE !c !e = do {- SCC "visitExpr.vE.accum" -} accum acc + {- SCC "visitExpr.vE.step" -} step c' e' where !c' = ctxExpr v c e !e' = txExpr v c' e !acc = accExpr v c' e - step _ !e@(ESym _) = return e - step _ !e@(ECon _) = return e - step _ !e@(EVar _) = return e - step !c !(EApp f e) = EApp <$> vE c f <*> vE c e - step !c !(ENeg e) = ENeg <$> vE c e - step !c !(EBin o e1 e2) = EBin o <$> vE c e1 <*> vE c e2 - step !c !(EIte p e1 e2) = EIte <$> vE c p <*> vE c e1 <*> vE c e2 - step !c !(ECst e t) = (`ECst` t) <$> vE c e - step !c !(PAnd ps) = PAnd <$> (vE c <$$> ps) - step !c !(POr ps) = POr <$> (vE c <$$> ps) - step !c !(PNot p) = PNot <$> vE c p - step !c !(PImp p1 p2) = PImp <$> vE c p1 <*> vE c p2 - step !c !(PIff p1 p2) = PIff <$> vE c p1 <*> vE c p2 - step !c !(PAtom r e1 e2) = PAtom r <$> vE c e1 <*> vE c e2 - step !c !(PAll xts p) = PAll xts <$> vE c p - step !c !(ELam (x,t) e) = ELam (x,t) <$> vE c e - step !c !(ECoerc a t e) = ECoerc a t <$> vE c e - step !c !(PExist xts p) = PExist xts <$> vE c p - step !c !(ETApp e s) = (`ETApp` s) <$> vE c e - step !c !(ETAbs e s) = (`ETAbs` s) <$> vE c e - step _ !p@(PKVar _ _) = return p - step !c !(PGrad k su i e) = PGrad k su i <$> vE c e + step _ e@(ESym _) = return e + step _ e@(ECon _) = return e + step _ e@(EVar _) = return e + step !c (EApp f e) = EApp <$> vE c f <*> vE c e + step !c (ENeg e) = ENeg <$> vE c e + step !c (EBin o e1 e2) = EBin o <$> vE c e1 <*> vE c e2 + step !c (EIte p e1 e2) = EIte <$> vE c p <*> vE c e1 <*> vE c e2 + step !c (ECst e t) = (`ECst` t) <$> vE c e + step !c (PAnd ps) = PAnd <$> (vE c `traverse` ps) + step !c (POr ps) = POr <$> (vE c `traverse` ps) + step !c (PNot p) = PNot <$> vE c p + step !c (PImp p1 p2) = PImp <$> vE c p1 <*> vE c p2 + step !c (PIff p1 p2) = PIff <$> vE c p1 <*> vE c p2 + step !c (PAtom r e1 e2) = PAtom r <$> vE c e1 <*> vE c e2 + step !c (PAll xts p) = PAll xts <$> vE c p + step !c (ELam (x,t) e) = ELam (x,t) <$> vE c e + step !c (ECoerc a t e) = ECoerc a t <$> vE c e + step !c (PExist xts p) = PExist xts <$> vE c p + step !c (ETApp e s) = (`ETApp` s) <$> vE c e + step !c (ETAbs e s) = (`ETAbs` s) <$> vE c e + step _ p@(PKVar _ _) = return p + step !c (PGrad k su i e) = PGrad k su i <$> vE c e mapKVars :: Visitable t => (KVar -> Maybe Expr) -> t -> t mapKVars f = mapKVars' f' @@ -268,24 +249,24 @@ go e@(ECon _) = f e go e@(EVar _) = f e go e@(PKVar _ _) = f e - go (PGrad k s i e) = f =<< (PGrad k s i <$> go e ) - go (ENeg e) = f =<< (ENeg <$> go e ) - go (PNot p) = f =<< (PNot <$> go p ) - go (ECst e t) = f =<< ((`ECst` t) <$> go e ) - go (PAll xts p) = f =<< (PAll xts <$> go p ) - go (ELam (x,t) e) = f =<< (ELam (x,t) <$> go e ) - go (ECoerc a t e) = f =<< (ECoerc a t <$> go e ) - go (PExist xts p) = f =<< (PExist xts <$> go p ) - go (ETApp e s) = f =<< ((`ETApp` s) <$> go e ) - go (ETAbs e s) = f =<< ((`ETAbs` s) <$> go e ) + go (PGrad k s i e) = f . PGrad k s i =<< go e + go (ENeg e) = f . ENeg =<< go e + go (PNot p) = f . PNot =<< go p + go (ECst e t) = f . (`ECst` t) =<< go e + go (PAll xts p) = f . PAll xts =<< go p + go (ELam (x,t) e) = f . ELam (x,t) =<< go e + go (ECoerc a t e) = f . ECoerc a t =<< go e + go (PExist xts p) = f . PExist xts =<< go p + go (ETApp e s) = f . (`ETApp` s) =<< go e + go (ETAbs e s) = f . (`ETAbs` s) =<< go e go (EApp g e) = f =<< (EApp <$> go g <*> go e ) go (EBin o e1 e2) = f =<< (EBin o <$> go e1 <*> go e2 ) go (PImp p1 p2) = f =<< (PImp <$> go p1 <*> go p2 ) go (PIff p1 p2) = f =<< (PIff <$> go p1 <*> go p2 ) go (PAtom r e1 e2) = f =<< (PAtom r <$> go e1 <*> go e2 ) go (EIte p e1 e2) = f =<< (EIte <$> go p <*> go e1 <*> go e2) - go (PAnd ps) = f =<< (PAnd <$> (go <$$> ps) ) - go (POr ps) = f =<< (POr <$> (go <$$> ps) ) + go (PAnd ps) = f . PAnd =<< (go `traverse` ps) + go (POr ps) = f . POr =<< (go `traverse` ps) mapKVarSubsts :: Visitable t => (KVar -> Subst -> Subst) -> t -> t mapKVarSubsts f = trans kvVis () () @@ -354,13 +335,13 @@ PAnd ps -> foldr (flip go) acc ps POr ps -> foldr (flip go) acc ps -envKVars :: (TaggedC c a) => BindEnv -> c a -> [KVar] +envKVars :: (TaggedC c a) => BindEnv a -> c a -> [KVar] envKVars be c = squish [ kvs sr | (_, sr) <- clhs be c] where squish = S.toList . S.fromList . concat kvs = kvarsExpr . reftPred . sr_reft -envKVarsN :: (TaggedC c a) => BindEnv -> c a -> [(KVar, Int)] +envKVarsN :: (TaggedC c a) => BindEnv a -> c a -> [(KVar, Int)] envKVarsN be c = tally [ kvs sr | (_, sr) <- clhs be c] where tally = Misc.count . concat @@ -376,9 +357,9 @@ isConcC = all isConc . conjuncts . crhs isKvar :: Expr -> Bool -isKvar (PKVar {}) = True -isKvar (PGrad {}) = True -isKvar _ = False +isKvar PKVar{} = True +isKvar PGrad{} = True +isKvar _ = False isConc :: Expr -> Bool isConc = null . kvarsExpr @@ -400,16 +381,17 @@ -- to the ty-vars that they should be substituted with. Note the -- domain and range are both Symbol and not the Int used for real ty-vars. -------------------------------------------------------------------------------- -type CoSub = M.HashMap Symbol Sort +type CoSub = M.HashMap Symbol Sort applyCoSub :: CoSub -> Expr -> Expr -applyCoSub coSub = mapExpr fE +applyCoSub coSub = mapExprOnExpr fE where fE (ECoerc s t e) = ECoerc (txS s) (txS t) e fE (ELam (x,t) e) = ELam (x, txS t) e + fE (ECst e t) = ECst e (txS t) fE e = e - txS = mapSort fS - fS (FObj a) = {- FObj -} (txV a) + txS = mapSortOnlyOnce fS + fS (FObj a) = {- FObj -} txV a fS t = t txV a = M.lookupDefault (FObj a) a coSub @@ -425,13 +407,31 @@ go b (FAbs _ t) = go b t go b _ = b +-- | Like 'mapSort' but it doesn't substitute on the result +-- of the function. +-- +-- > mapSortOnlyOnce [(a,b), (b,c)] a = b +-- +-- whereas +-- +-- > mapSort [(a,b), (b,c)] a = c +-- +mapSortOnlyOnce :: (Sort -> Sort) -> Sort -> Sort +mapSortOnlyOnce f = step + where + step !x = f $ go x + go (FFunc t1 t2) = FFunc (step t1) (step t2) + go (FApp t1 t2) = FApp (step t1) (step t2) + go (FAbs i t) = FAbs i (step t) + go !t = t + mapSort :: (Sort -> Sort) -> Sort -> Sort mapSort f = step where step !x = go (f x) - go !(FFunc t1 t2) = FFunc (step t1) (step t2) - go !(FApp t1 t2) = FApp (step t1) (step t2) - go !(FAbs i t) = FAbs i (step t) + go (FFunc t1 t2) = FFunc (step t1) (step t2) + go (FApp t1 t2) = FApp (step t1) (step t2) + go (FAbs i t) = FAbs i (step t) go !t = t foldDataDecl :: (a -> Sort -> a) -> a -> DataDecl -> a @@ -454,16 +454,16 @@ instance SymConsts a => SymConsts [a] where - symConsts xs = concatMap symConsts xs - -instance SymConsts AxiomEnv where + symConsts xs = concatMap symConsts xs + +instance SymConsts AxiomEnv where symConsts xs = symConsts (aenvEqs xs) ++ symConsts (aenvSimpl xs) -instance SymConsts Equation where - symConsts = symConsts . eqBody +instance SymConsts Equation where + symConsts = symConsts . eqBody -instance SymConsts Rewrite where - symConsts = symConsts . smBody +instance SymConsts Rewrite where + symConsts = symConsts . smBody -- instance SymConsts (FInfo a) where @@ -474,8 +474,8 @@ bsLits = symConsts $ bs fi qsLits = concatMap symConsts $ qBody <$> quals fi -instance SymConsts BindEnv where - symConsts = concatMap (symConsts . snd) . M.elems . beBinds +instance SymConsts (BindEnv a) where + symConsts = concatMap (symConsts . Misc.snd3) . M.elems . beBinds instance SymConsts (SubC a) where symConsts c = symConsts (slhs c) ++ diff --git a/src/Language/Fixpoint/Utils/Builder.hs b/src/Language/Fixpoint/Utils/Builder.hs --- a/src/Language/Fixpoint/Utils/Builder.hs +++ b/src/Language/Fixpoint/Utils/Builder.hs @@ -22,6 +22,7 @@ , blt ) where +import Data.Foldable (fold) import Data.String import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy as LT @@ -61,6 +62,7 @@ parens :: Builder -> Builder parens b = "(" <> b <> ")" +infixl 9 <+> (<+>) :: Builder -> Builder -> Builder x <+> y = x <> " " <> y @@ -77,7 +79,7 @@ key3 k b1 b2 b3 = parenSeqs [k, b1, b2, b3] seqs :: [Builder] -> Builder -seqs = foldr (<>) mempty . L.intersperse " " +seqs = fold . L.intersperse " " bShow :: Show a => a -> Builder bShow = fromString . show diff --git a/src/Language/Fixpoint/Utils/Files.hs b/src/Language/Fixpoint/Utils/Files.hs --- a/src/Language/Fixpoint/Utils/Files.hs +++ b/src/Language/Fixpoint/Utils/Files.hs @@ -74,7 +74,7 @@ | Js -- ^ JavaScript source | Ts -- ^ Typescript source | Spec -- ^ Spec file (e.g. include/Prelude.spec) - | BinSpec -- ^ Lifted-Spec file, containing automatically generated specifications + | BinSpec -- ^ Lifted-Spec file, containing automatically generated specifications | Hquals -- ^ Qualifiers file (e.g. include/Prelude.hquals) | Result -- ^ Final result: SAFE/UNSAFE | Cst -- ^ HTML file with templates? diff --git a/src/Language/Fixpoint/Utils/Trie.hs b/src/Language/Fixpoint/Utils/Trie.hs --- a/src/Language/Fixpoint/Utils/Trie.hs +++ b/src/Language/Fixpoint/Utils/Trie.hs @@ -1,4 +1,4 @@ -module Language.Fixpoint.Utils.Trie +module Language.Fixpoint.Utils.Trie ( -- * Datatype Trie (..) , Branch (..) @@ -8,75 +8,75 @@ , insert , fromList - -- * Visitors - , fold + -- * Visitors + , fold , foldM - ) - where + ) + where -import qualified Data.List as L -import Language.Fixpoint.Types.PrettyPrint +import qualified Data.List as L +import Language.Fixpoint.Types.PrettyPrint import qualified Language.Fixpoint.Misc as Misc type Key = Int type Path = [Key] -data Trie a - = Node ![Branch a] +newtype Trie a + = Node [Branch a] deriving (Eq, Show) -data Branch a +data Branch a = Bind !Key !(Trie a) - | Val a + | Val a deriving (Eq, Show) ------------------------------------------------------------------------------- -empty :: Trie a +empty :: Trie a ------------------------------------------------------------------------------- empty = Node [] ------------------------------------------------------------------------------- -insert :: Path -> a -> Trie a -> Trie a +insert :: Path -> a -> Trie a -> Trie a ------------------------------------------------------------------------------- -insert [] v (Node ts) = Node ((Val v) : ts) +insert [] v (Node ts) = Node (Val v : ts) insert (i:is) v (Node ts) = Node (insertKey i is v ts) ------------------------------------------------------------------------------- -fromList :: [(Path, a)] -> Trie a +fromList :: [(Path, a)] -> Trie a ------------------------------------------------------------------------------- -fromList = L.foldl' (\t (k, v) -> insert k v t) empty +fromList = L.foldl' (\t (k, v) -> insert k v t) empty --- i=3 --- 0 1 2 3 4 5 6 - +-- i=3 +-- 0 1 2 3 4 5 6 + insertKey :: Key -> Path -> a -> [Branch a] -> [Branch a] -insertKey i is v bs@((Bind j tj) : bs') - | i == j = Bind i (insert is v tj) : bs' - | i < j = Bind i (pathTrie is v) : bs -insertKey i is v (b:bs) = b : insertKey i is v bs -insertKey i is v [] = [ Bind i (pathTrie is v) ] +insertKey i is v bs@((Bind j tj) : bs') + | i == j = Bind i (insert is v tj) : bs' + | i < j = Bind i (pathTrie is v) : bs +insertKey i is v (b:bs) = b : insertKey i is v bs +insertKey i is v [] = [ Bind i (pathTrie is v) ] -pathTrie :: Path -> a -> Trie a -pathTrie [] v = Node [Val v] +pathTrie :: Path -> a -> Trie a +pathTrie [] v = Node [Val v] pathTrie (i:is) v = Node [Bind i (pathTrie is v)] ------------------------------------------------------------------------------- -fold :: (acc -> Path -> a -> acc) -> acc -> Trie a -> acc +fold :: (acc -> Path -> a -> acc) -> acc -> Trie a -> acc ------------------------------------------------------------------------------- fold = undefined ------------------------------------------------------------------------------- -foldM :: (Monad m) => (acc -> Path -> a -> m acc) -> acc -> Trie a -> m acc +foldM :: (Monad m) => (acc -> Path -> a -> m acc) -> acc -> Trie a -> m acc ------------------------------------------------------------------------------- foldM = undefined -instance Show a => PPrint (Trie a) where - pprintTidy _ = Misc.tshow +instance Show a => PPrint (Trie a) where + pprintTidy _ = Misc.tshow -{- +{- e1 <---- @@ -108,14 +108,14 @@ as the `trie` - 1 -> 2 -----------> A + 1 -> 2 -----------> A `-> 3 -> 4 -> B | ` -> 5 -> C `-> 6 ------------> D -} --- >>> _example0 == _example1 +-- >>> _example0 == _example1 -- True _example0 :: Trie Char @@ -126,7 +126,7 @@ n3 = Node [Bind 4 n4, Bind 5 n5] n4 = Node [Val 'B'] n5 = Node [Val 'C'] - n6 = Node [Val 'D'] + n6 = Node [Val 'D'] _example1 :: Trie Char diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,20 +0,0 @@ - -resolver: lts-18.14 -compiler: ghc-8.10.7 -# compiler: ghc-8.8.4 -# compiler: ghc-8.6.5 -allow-newer: true - -# resolver: lts-14.0 - -flags: - liquid-fixpoint: - devel: true - -packages: -- '.' - - -extra-deps: -- hashable-1.3.0.0 -- rest-rewrite-0.1.1 diff --git a/tests/crash/EqConstr0.fq b/tests/crash/EqConstr0.fq deleted file mode 100644 --- a/tests/crash/EqConstr0.fq +++ /dev/null @@ -1,9 +0,0 @@ - -bind 1 x : {v: int | true } -bind 2 y : {v: a | true } - -constraint: - env [1; 2] - lhs {v: int | x = y } - rhs {v: Int | y = x } - id 1 tag [] diff --git a/tests/crash/EqConstr1.fq b/tests/crash/EqConstr1.fq deleted file mode 100644 --- a/tests/crash/EqConstr1.fq +++ /dev/null @@ -1,12 +0,0 @@ -data Thing 0 = [ - | mkCons { head : int } -] - -bind 1 x : {v: Thing | true } -bind 2 y : {v: a | true } - -constraint: - env [1; 2] - lhs {v: int | x = y } - rhs {v: Int | y = x } - id 1 tag [] diff --git a/tests/crash/num00.fq b/tests/crash/num00.fq deleted file mode 100644 --- a/tests/crash/num00.fq +++ /dev/null @@ -1,29 +0,0 @@ -// This qualifier saves the day; solve constraints WITHOUT IT - -qualif Zog(v:a) : (0 <= v) -qualif Bog(v:a) : (0 <= 1) - - -bind 0 zog : {v : int | true} - -constraint: - env [0] - lhs {v : alpha | (v = 10)} - rhs {v : alpha | $k0} - id 1 tag [] - -constraint: - env [0] - lhs {v : alpha | $k0} - rhs {v : alpha | $k0} - id 2 tag [] - -constraint: - env [0] - lhs {v : alpha | $k0} - rhs {v : alpha | 0 <= v} - id 3 tag [] - -wf: - env [0] - reft {v: alpha | $k0} diff --git a/tests/crash/sort00.fq b/tests/crash/sort00.fq deleted file mode 100644 --- a/tests/crash/sort00.fq +++ /dev/null @@ -1,12 +0,0 @@ -// for LH Issue 773 - -constant foo : (func(0, [int; int])) - -bind 0 x : {v: Str | true} - -constraint: - env [ 0 ] - lhs {v : int | (foo x = 0)} - rhs {v : int | (3 = 1 + 2) } - id 1 tag [] - diff --git a/tests/crash/sort01.fq b/tests/crash/sort01.fq deleted file mode 100644 --- a/tests/crash/sort01.fq +++ /dev/null @@ -1,13 +0,0 @@ -// for LH Issue 774 - -constant foo : (func(0, [int; int])) - -bind 0 x : {v: Str | true} -bind 1 y : {v: Str | true} - -constraint: - env [ 0; 1 ] - lhs {v : int | (foo x = foo y)} - rhs {v : int | (3 = 1 + 2) } - id 1 tag [] - diff --git a/tests/cut/test00-tx.fq b/tests/cut/test00-tx.fq deleted file mode 100644 --- a/tests/cut/test00-tx.fq +++ /dev/null @@ -1,12 +0,0 @@ - - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 a : {v:int | (v = 10 || v = 20) } - -constraint: - env [ 0 ] - lhs {v : int | v = a} - rhs {v : int | 10 <= v} - id 3 diff --git a/tests/cut/test00.fq b/tests/cut/test00.fq deleted file mode 100644 --- a/tests/cut/test00.fq +++ /dev/null @@ -1,28 +0,0 @@ - - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 a : {v: int | $k0} - -constraint: - env [ ] - lhs {v : int | (v = 10)} - rhs {v : int | $k0} - id 1 - -constraint: - env [ ] - lhs {v : int | v = 20} - rhs {v : int | $k0} - id 2 - -constraint: - env [ 0 ] - lhs {v : int | v = a} - rhs {v : int | 10 <= v} - id 3 - -wf: - env [ ] - reft {v: int | $k0} diff --git a/tests/cut/test00a-tx.fq b/tests/cut/test00a-tx.fq deleted file mode 100644 --- a/tests/cut/test00a-tx.fq +++ /dev/null @@ -1,43 +0,0 @@ -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -constraint: - env [z : {v : int | true}] - lhs {v : int | (z=10) \/ (z=20)} - rhs {v : int | 10 <= z} - id 3 - -/* - -Rewriting constraints as: - - id 1 - x:int, v:int |- x=10 /\ v=x => k0 - - id 2 - y:int, v:int |- y=20 /\ v=y => k0 - -Projecting out all variables NOT in the WF of k0 - - id 1 - v:int |- (exists x:int. x=10 /\ v=x) => k0 - - id 2 - v:int |- (exists y:int. y=20 /\ v=y) => k0 - -Take the \/ of all constraints on k0 - - k0 = (exists x:int. x=10 /\ v=x) \/ (exists y:int. y=20 /\ v=y) - - k0[z/v] - = (\x. x=10 /\ v=x) \/ (\y. y=20 /\ v=y)[z/v] - = (\x. x=10 /\ z=x) \/ (\y. y=20 /\ z=y) - -So you get: - - env [2] - lhs {v : int | (\x. x=10 /\ z=x) \/ (\y. y=20 /\ z=y)} - rhs {v : int | 10 <= z} - id 3 - -*/ diff --git a/tests/cut/test00a.fq b/tests/cut/test00a.fq deleted file mode 100644 --- a/tests/cut/test00a.fq +++ /dev/null @@ -1,29 +0,0 @@ -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 x : {v : int | true} -bind 1 y : {v : int | true} -bind 2 z : {v : int | true} - -constraint: - env [0] - lhs {v : int | (x = 10)} - rhs {v : int | $k0[v:=x]} - id 1 - -constraint: - env [1] - lhs {v : int | y = 20} - rhs {v : int | $k0[v:=y]} - id 2 - -constraint: - env [2] - lhs {v : int | $k0[v:=z]} - rhs {v : int | 10 <= z} - id 3 - -wf: - env [ ] - reft {v: int | $k0} - diff --git a/tests/cut/test1-tx.fq b/tests/cut/test1-tx.fq deleted file mode 100644 --- a/tests/cut/test1-tx.fq +++ /dev/null @@ -1,43 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -constraint: - env [a : {v : int | (exists x:int. x=10 /\ v=x) - \/ (exists y:int. y=20 /\ v=y) }] - lhs {v : int | v = a } - rhs {v : int | 10 <= v} - id 3 - -/* - -Rewriting constraints as: - - id 1 - x:int, v:int |- (v=10)[x/v] /\ (v=x) => k0 - x:int, v:int |- (x=10) /\ (v=x) => k0 - - id 2 - y:int, v:int |- (v=20)[y/v] /\ (v=y) => k0 - y:int, v:int |- (y=20) /\ (v=y) => k0 - -Projecting out all variables NOT in the WF of k0 - - id 1 - v:int |- (exists x:int. x=10 /\ v=x) => k0 - - id 2 - v:int |- (exists y:int. y=20 /\ v=y) => k0 - -Take the \/ of all constraints on k0 - - k0 = (exists x:int. x=10 /\ v=x) \/ (exists y:int. y=20 /\ v=y) - -So you get: - - env [a : {v : int | (exists x:int. x=10 /\ v=x) \/ (exists y:int. y=20 /\ v=y) }] - lhs {v : int | v = a } - rhs {v : int | 10 <= v} - id 3 - -*/ diff --git a/tests/cut/test1.fq b/tests/cut/test1.fq deleted file mode 100644 --- a/tests/cut/test1.fq +++ /dev/null @@ -1,29 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 x : {v : int | v = 10} -bind 1 y : {v : int | v = 20} -bind 2 a : {v : int | $k0 } - -constraint: - env [0] - lhs {v : int | v = x} - rhs {v : int | $k0 } - id 1 - -constraint: - env [1] - lhs {v : int | v = y} - rhs {v : int | $k0 } - id 2 - -constraint: - env [2] - lhs {v : int | v = a } - rhs {v : int | 10 <= v} - id 3 - -wf: - env [ ] - reft {v : int | $k0} diff --git a/tests/cut/test2-tx.fq b/tests/cut/test2-tx.fq deleted file mode 100644 --- a/tests/cut/test2-tx.fq +++ /dev/null @@ -1,112 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a): (10 <= v) - -// But you may use this one -qualif Pog(v:a): (0 <= v) - - - - -/* - --- Version 1 (eliminate k1) -- - -Rewriting constraints as: - - id 0 - v:int |- (v=0) => k1 - - id 3 - v:int |- k0 => k1 - -Projecting out all variables NOT in the WF of k1 - - N/A - -Take the \/ of all constraints on k1 - - k1 = (v=0) \/ k0 - -So you get: - - bind 0 x: {v: int | v = 10 } - bind 1 a: {v: int | (v=0) \/ k0 } - bind 2 y: {v: int | v = 20 } - bind 3 b: {v: int | (v=0) \/ k0 } - bind 4 c: {v: int | k0 } - - constraint: - env [ 0; 1] - lhs {v : int | v = x + a} - rhs {v : int | k0} - id 1 - - constraint: - env [2; 3] - lhs {v : int | v = y + b} - rhs {v : int | k0} - id 2 - - constraint: - env [4] - lhs {v : int | v = c } - rhs {v : int | 10 <= v} - id 4 - - wf: - env [ ] - reft {v: int | k1} - - - - --- Version 2 (eliminate k0) -- - -Rewriting constraints as: - - id 1 - x:int, a:int, v:int |- (v=10)[x/v] /\ k1[a/v] /\ (v=x+a) => k0 - x:int, a:int, v:int |- (x=10) /\ k1[a/v] /\ (v=x+a) => k0 - - id 2 - y:int, b:int, v:int |- (v=20)[y/v] /\ k1[b/v] /\ (v=y+b) => k0 - y:int, b:int, v:int |- (y=20) /\ k1[b/v] /\ (v=y+b) => k0 - -Projecting out all variables NOT in the WF of k0 - - id 1 - v:int |- (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a)) => k0 - - id 2 - v:int |- (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b)) => k0 - -Take the \/ of all constraints on k0 - - k0 = (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a)) - \/ (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b)) - -So you get: - - bind 4 c: {v: int | (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a)) - \/ (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b)) } - - constraint: - env [ ] - lhs {v : int | v = 0} - rhs {v : int | k1 } - id 0 - - - constraint: - env [ ] - lhs {v : int | (exists x:int a:int. (x=10) /\ k1[a/v] /\ (v=x+a)) - \/ (exists y:int b:int. (y=20) /\ k1[b/v] /\ (v=y+b))} - rhs {v : int | k1} - id 3 - - constraint: - env [4] - lhs {v : int | v = c } - rhs {v : int | 10 <= v} - id 4 diff --git a/tests/cut/test2.fq b/tests/cut/test2.fq deleted file mode 100644 --- a/tests/cut/test2.fq +++ /dev/null @@ -1,51 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a): (10 <= v) - -// But you may use this one -qualif Pog(v:a): (0 <= v) - -bind 0 x: {v: int | v = 10} -bind 1 a: {v: int | $k1 } -bind 2 y: {v: int | v = 20} -bind 3 b: {v: int | $k1 } -bind 4 c: {v: int | $k0 } - -constraint: - env [ ] - lhs {v : int | v = 0} - rhs {v : int | $k1 } - id 0 - - -constraint: - env [ 0; 1] - lhs {v : int | v = x + a} - rhs {v : int | $k0} - id 1 - -constraint: - env [2; 3] - lhs {v : int | v = y + b} - rhs {v : int | $k0} - id 2 - -constraint: - env [ ] - lhs {v : int | $k0} - rhs {v : int | $k1} - id 3 - -constraint: - env [4] - lhs {v : int | v = c } - rhs {v : int | 10 <= v} - id 4 - -wf: - env [ ] - reft {v: int | $k0} - -wf: - env [ ] - reft {v: int | $k1} diff --git a/tests/elim/div00.fq b/tests/elim/div00.fq deleted file mode 100644 --- a/tests/elim/div00.fq +++ /dev/null @@ -1,23 +0,0 @@ - -// --eliminate should be able to solve this WITHOUT the qualifier -// qualif Zog(v:int) : (v /= 0) - -bind 0 n : {v: int | true } -bind 1 m : {v: int | true } -bind 2 z : {v: int | $k0[n := m] } - -constraint: - env [ ] - lhs {v : int | v = 12 } - rhs {v : int | $k0 } - id 1 tag [] - -constraint: - env [ 1; 2 ] - lhs {v : int | v = z} - rhs {v : int | v /= 0} - id 2 tag [] - -wf: - env [ 0 ] - reft {v: int | $k0 } diff --git a/tests/elim/elim00.fq b/tests/elim/elim00.fq deleted file mode 100644 --- a/tests/elim/elim00.fq +++ /dev/null @@ -1,1494 +0,0 @@ -fixpoint "--defunct" - -// qualif Cmp(v : @(0), x : @(0)): ((v > x)) // "tests/todo/elim00.hs.fq" (line 1, column 8) -// qualif Cmp(v : @(0), x : @(0)): ((v = x)) // "tests/todo/elim00.hs.fq" (line 2, column 8) - - -constant Control.Exception.Base.irrefutPatError##09 : (func(1, [int; - @(0)])) -constant GHC.Base..##r2C : (func(3, [func(0, [@(0); @(1)]); - func(0, [@(2); @(0)]); - @(2); - @(1)])) -constant runFun : (func(2, [(Arrow @(0) @(1)); @(0); @(1)])) -constant GHC.Tuple.$40$$44$$44$$41$$35$$35$76 : (func(3, [@(0); - @(1); - @(2); - (Tuple @(0) @(1) @(2))])) -constant GHC.Real.D$58$Integral$35$$35$rWH : (func(1, [func(0, [@(0); - @(0); - @(0)]); - func(0, [@(0); @(0); @(0)]); - func(0, [@(0); @(0); @(0)]); - func(0, [@(0); @(0); @(0)]); - func(0, [@(0); @(0); (Tuple @(0) @(0))]); - func(0, [@(0); @(0); (Tuple @(0) @(0))]); - func(0, [@(0); int]); - (GHC.Real.Integral @(0))])) -constant addrLen : (func(0, [int; int])) -constant papp5 : (func(10, [(Pred @(0) @(1) @(2) @(3) @(4)); - @(5); - @(6); - @(7); - @(8); - @(9); - bool])) -constant xsListSelector : (func(1, [[@(0)]; [@(0)]])) -constant x_Tuple21 : (func(2, [(Tuple @(0) @(1)); @(0)])) -constant x_Tuple65 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); - @(4)])) -constant Elim.foo##rlD : (func(0, [Elim.Foo; Elim.Foo])) -constant x_Tuple55 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); - @(4)])) -constant GHC.Integer.Type.smallInteger##0Z : (func(0, [int; int])) -constant x_Tuple33 : (func(3, [(Tuple @(0) @(1) @(2)); @(2)])) -constant x_Tuple77 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(6)])) -constant GHC.Base.Just##r1e : (func(1, [@(0); - (GHC.Base.Maybe @(0))])) -constant Elim.xx##rlB : (func(0, [Elim.Foo; int])) -constant papp3 : (func(6, [(Pred @(0) @(1) @(2)); - @(3); - @(4); - @(5); - bool])) -constant GHC.Prim.$43$$35$$35$$35$98 : (func(0, [int; int; int])) -constant x_Tuple63 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); - @(2)])) -constant x_Tuple41 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); - @(0)])) -constant GHC.Types.LT##6S : (GHC.Types.Ordering) -constant GHC.Prim.$60$$35$$35$$35$9q : (func(0, [int; int; int])) -constant papp4 : (func(8, [(Pred @(0) @(1) @(2) @(3)); - @(4); - @(5); - @(6); - @(7); - bool])) -constant Elim.PP##rlx : (func(2, [@(0); - @(1); - (Elim.Pair @(0) @(1))])) -constant x_Tuple64 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); - @(3)])) -constant GHC.Types.GT##6W : (GHC.Types.Ordering) -constant GHC.Prim.$45$$35$$35$$35$99 : (func(0, [int; int; int])) -constant GHC.Types.$58$$35$$35$64 : (func(1, [@(0); - [@(0)]; - [@(0)]])) -constant autolen : (func(1, [@(0); int])) -constant GHC.Types.I###6c : (func(0, [int; int])) -constant x_Tuple52 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); - @(1)])) -constant xx : (func(0, [Elim.Foo; int])) -constant null : (func(1, [[@(0)]; bool])) -constant GHC.Num.$43$$35$$35$rt : (func(1, [@(0); @(0); @(0)])) -constant GHC.Tuple.$40$$44$$44$$44$$44$$41$$35$$35$7a : (func(5, [@(0); - @(1); - @(2); - @(3); - @(4); - (Tuple @(0) @(1) @(2) @(3) @(4))])) -constant papp2 : (func(4, [(Pred @(0) @(1)); @(2); @(3); bool])) -constant x_Tuple62 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); - @(1)])) -constant GHC.Tuple.$40$$44$$41$$35$$35$74 : (func(2, [@(0); - @(1); - (Tuple @(0) @(1))])) -constant Elim.yy##rlC : (func(0, [Elim.Foo; int])) -constant fromJust : (func(1, [(GHC.Base.Maybe @(0)); @(0)])) -constant papp7 : (func(14, [(Pred @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(7); - @(8); - @(9); - @(10); - @(11); - @(12); - @(13); - bool])) -constant x_Tuple53 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); - @(2)])) -constant x_Tuple71 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(0)])) -constant GHC.Prim.$62$$35$$35$$35$9m : (func(0, [int; int; int])) -constant x_Tuple74 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(3)])) -constant Elim.Emp##rly : (func(2, [(Elim.Pair @(0) @(1))])) -constant len : (func(2, [(@(0) @(1)); int])) -constant GHC.Tuple.$40$$44$$44$$44$$44$$44$$44$$41$$35$$35$7e : (func(7, [@(0); - @(1); - @(2); - @(3); - @(4); - @(5); - @(6); - (Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6))])) -constant papp6 : (func(12, [(Pred @(0) @(1) @(2) @(3) @(4) @(5)); - @(6); - @(7); - @(8); - @(9); - @(10); - @(11); - bool])) -constant x_Tuple22 : (func(2, [(Tuple @(0) @(1)); @(1)])) -constant Data.Foldable.length##r1s : (func(2, [(@(0) @(0)); int])) -constant x_Tuple66 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); - @(5)])) -constant x_Tuple44 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); - @(3)])) -constant xListSelector : (func(1, [[@(0)]; @(0)])) -constant strLen : (func(0, [int; int])) -constant x_Tuple72 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(1)])) -constant GHC.Tuple.$40$$44$$44$$44$$41$$35$$35$78 : (func(4, [@(0); - @(1); - @(2); - @(3); - (Tuple @(0) @(1) @(2) @(3))])) -constant isJust : (func(1, [(GHC.Base.Maybe @(0)); bool])) -constant GHC.Prim.$61$$61$$35$$35$$35$9o : (func(0, [int; - int; - int])) -constant Elim.Foo##rlA : (func(0, [int; int; Elim.Foo])) -constant Prop : (func(0, [GHC.Types.Bool; bool])) -constant x_Tuple31 : (func(3, [(Tuple @(0) @(1) @(2)); @(0)])) -constant x_Tuple75 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(4)])) -constant papp1 : (func(2, [(Pred @(0)); @(1); bool])) -constant yy : (func(0, [Elim.Foo; int])) -constant x_Tuple61 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); - @(0)])) -constant GHC.Prim.$62$$61$$35$$35$$35$9n : (func(0, [int; - int; - int])) -constant lit$36$tests$47$pos$47$elim00.hs$58$14$58$5$45$30$124$PP$32$wink$32$cow : (Str) -constant x_Tuple43 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); - @(2)])) -constant GHC.Types.EQ##6U : (GHC.Types.Ordering) -constant x_Tuple51 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); - @(0)])) -constant GHC.Base.Nothing##r1d : (func(1, [(GHC.Base.Maybe @(0))])) -constant GHC.Num.$45$$35$$35$02B : (func(1, [@(0); @(0); @(0)])) -constant GHC.Num.$42$$35$$35$ru : (func(1, [@(0); @(0); @(0)])) -constant x_Tuple73 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(2)])) -constant GHC.Types.$91$$93$$35$$35$6m : (func(1, [[@(0)]])) -constant x_Tuple54 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); - @(3)])) -constant cmp : (func(0, [GHC.Types.Ordering; GHC.Types.Ordering])) -constant x_Tuple32 : (func(3, [(Tuple @(0) @(1) @(2)); @(1)])) -constant x_Tuple76 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(5)])) -constant GHC.Prim.$60$$61$$35$$35$$35$9r : (func(0, [int; - int; - int])) -constant GHC.Real.D$58$Fractional$35$$35$rVU : (func(1, [func(0, [@(0); - @(0); - @(0)]); - func(0, [@(0); @(0)]); - func(0, [(GHC.Real.Ratio int); @(0)]); - (GHC.Real.Fractional @(0))])) -constant fst : (func(2, [(Tuple @(0) @(1)); @(0)])) -constant snd : (func(2, [(Tuple @(0) @(1)); @(1)])) -constant GHC.Tuple.$40$$44$$44$$44$$44$$44$$41$$35$$35$7c : (func(6, [@(0); - @(1); - @(2); - @(3); - @(4); - @(5); - (Tuple @(0) @(1) @(2) @(3) @(4) @(5))])) -constant x_Tuple42 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); - @(1)])) -constant GHC.Prim.void###0l : (GHC.Prim.Void#) - - -bind 0 GHC.Prim.void###0l : {VV##180 : GHC.Prim.Void# | []} -bind 1 Elim.Emp##rly : {VV : func(2, [(Elim.Pair @(0) @(1))]) | []} -bind 2 GHC.Types.EQ##6U : {VV##185 : GHC.Types.Ordering | [(VV##185 = GHC.Types.EQ##6U)]} -bind 3 GHC.Types.LT##6S : {VV##186 : GHC.Types.Ordering | [(VV##186 = GHC.Types.LT##6S)]} -bind 4 GHC.Types.GT##6W : {VV##187 : GHC.Types.Ordering | [(VV##187 = GHC.Types.GT##6W)]} -bind 5 Elim.Emp##rly : {VV : func(2, [(Elim.Pair @(0) @(1))]) | []} -bind 6 GHC.Types.$91$$93$$35$$35$6m : {VV : func(1, [[@(0)]]) | []} -bind 7 GHC.Types.GT##6W : {VV##213 : GHC.Types.Ordering | [((cmp VV##213) = GHC.Types.GT##6W)]} -bind 8 GHC.Types.LT##6S : {VV##214 : GHC.Types.Ordering | [((cmp VV##214) = GHC.Types.LT##6S)]} -bind 9 GHC.Types.EQ##6U : {VV##215 : GHC.Types.Ordering | [((cmp VV##215) = GHC.Types.EQ##6U)]} -bind 10 GHC.Base.Nothing##r1d : {VV : func(1, [(GHC.Base.Maybe @(0))]) | []} -bind 11 ds_dxd : {VV##222 : Elim.Foo | []} -bind 12 lq_anf$##dxr : {lq_tmp$x##223 : Elim.Foo | [(lq_tmp$x##223 = ds_dxd)]} -bind 13 lq_anf$##dxr : {lq_tmp$x##225 : Elim.Foo | [(lq_tmp$x##225 = ds_dxd)]} -bind 14 xig##awy : {lq_tmp$x##233 : int | []} -bind 15 yog##awz : {lq_tmp$x##234 : int | [(xig##awy < lq_tmp$x##234)]} -bind 16 lq_anf$##dxr : {lq_tmp$x##225 : Elim.Foo | [(lq_tmp$x##225 = ds_dxd); - ((yy lq_tmp$x##225) = yog##awz); - ((xx lq_tmp$x##225) = xig##awy); - (lq_tmp$x##225 = (Elim.Foo##rlA xig##awy yog##awz)); - ((yy lq_tmp$x##225) = yog##awz); - ((xx lq_tmp$x##225) = xig##awy)]} -bind 17 lq_anf$##dxs : {lq_tmp$x##242 : (Elim.Pair int int) | [(lq_tmp$x##242 = (Elim.PP##rlx xig##awy yog##awz))]} -bind 18 lq_anf$##dxt : {lq_tmp$x##273 : (Elim.Pair int int) | [(lq_tmp$x##273 = lq_anf$##dxs)]} -bind 19 lq_anf$##dxt : {lq_tmp$x##277 : (Elim.Pair int int) | [(lq_tmp$x##277 = lq_anf$##dxs)]} -bind 20 wink##ax3 : {lq_tmp$x##275 : int | [$k_##248[lq_tmp$x##277:=lq_anf$##dxt][VV##247:=lq_tmp$x##275][lq_tmp$x##242:=lq_anf$##dxt][lq_tmp$x##271:=lq_tmp$x##275][lq_tmp$x##273:=lq_anf$##dxt][lq_tmp$x##245:=xig##awy][lq_tmp$x##246:=yog##awz][lq_tmp$x##250:=lq_tmp$x##275]]} -bind 21 cow##ax4 : {lq_tmp$x##276 : int | [$k_##252[lq_tmp$x##277:=lq_anf$##dxt][lq_tmp$x##281:=wink##ax3][VV##251:=lq_tmp$x##276][lq_tmp$x##242:=lq_anf$##dxt][lq_tmp$x##254:=lq_tmp$x##276][lq_tmp$x##273:=lq_anf$##dxt][lq_tmp$x##245:=xig##awy][lq_tmp$x##246:=yog##awz][lq_tmp$x##272:=lq_tmp$x##276]]} -bind 22 lq_anf$##dxt : {lq_tmp$x##277 : (Elim.Pair int int) | [(lq_tmp$x##277 = lq_anf$##dxs); - (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4)); - (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4)); - (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4))]} -bind 23 lq_tmp$x##307 : {VV##308 : int | []} -bind 24 lq_anf$##dxt : {lq_tmp$x##313 : (Elim.Pair int int) | [(lq_tmp$x##313 = lq_anf$##dxs)]} -bind 25 lq_anf$##dxt : {lq_tmp$x##313 : (Elim.Pair int int) | [(lq_tmp$x##313 = lq_anf$##dxs); - (lq_tmp$x##313 = Elim.Emp##rly); - (lq_tmp$x##313 = Elim.Emp##rly); - (lq_tmp$x##313 = Elim.Emp##rly)]} -bind 26 ds_dxg : {VV##318 : GHC.Prim.Void# | [$k_##319]} -bind 27 lq_anf$##dxu : {lq_tmp$x##335 : int | [(lq_tmp$x##335 ~~ lit$36$tests$47$pos$47$elim00.hs$58$14$58$5$45$30$124$PP$32$wink$32$cow); - ((strLen lq_tmp$x##335) = 39)]} -bind 28 ds_dxh : {VV##268 : (Tuple int int) | [$k_##269]} -bind 29 lq_anf$##dxw : {lq_tmp$x##368 : (Tuple int int) | [(lq_tmp$x##368 = ds_dxh)]} -bind 30 lq_anf$##dxw : {lq_tmp$x##374 : (Tuple int int) | [(lq_tmp$x##374 = ds_dxh)]} -bind 31 wink##ax3 : {lq_tmp$x##370 : int | [$k_##259[lq_tmp$x##368:=lq_anf$##dxw][VV##268:=lq_anf$##dxw][lq_tmp$x##364:=lq_tmp$x##370][VV##258:=lq_tmp$x##370][lq_tmp$x##374:=lq_anf$##dxw]]} -bind 32 cow##Xxd : {lq_tmp$x##371 : int | [$k_##262[lq_tmp$x##368:=lq_anf$##dxw][VV##268:=lq_anf$##dxw][VV##261:=lq_tmp$x##371][lq_tmp$x##365:=lq_tmp$x##371][lq_tmp$x##379:=wink##ax3][lq_tmp$x##374:=lq_anf$##dxw]; - $k_##266[lq_tmp$x##368:=lq_anf$##dxw][lq_tmp$x##373:=lq_tmp$x##371][VV##265:=lq_tmp$x##371][lq_tmp$x##264:=wink##ax3][lq_tmp$x##367:=lq_tmp$x##371][VV##268:=lq_anf$##dxw][lq_tmp$x##372:=wink##ax3][lq_tmp$x##366:=wink##ax3][lq_tmp$x##379:=wink##ax3][lq_tmp$x##374:=lq_anf$##dxw]]} -bind 33 lq_anf$##dxw : {lq_tmp$x##374 : (Tuple int int) | [(lq_tmp$x##374 = ds_dxh); - ((snd lq_tmp$x##374) = cow##Xxd); - ((fst lq_tmp$x##374) = wink##ax3); - ((x_Tuple22 lq_tmp$x##374) = cow##Xxd); - ((x_Tuple21 lq_tmp$x##374) = wink##ax3); - (lq_tmp$x##374 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##Xxd)); - ((snd lq_tmp$x##374) = cow##Xxd); - ((fst lq_tmp$x##374) = wink##ax3); - ((x_Tuple22 lq_tmp$x##374) = cow##Xxd); - ((x_Tuple21 lq_tmp$x##374) = wink##ax3)]} -bind 34 wink##ax3 : {VV##361 : int | [$k_##362]} -// bind 45 wink##ax3 : {lq_tmp$x##452 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][VV##427:=lq_tmp$x##452][lq_tmp$x##426:=cow##ax4][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##430:=lq_tmp$x##452][lq_tmp$x##446:=lq_tmp$x##452][lq_tmp$x##422:=lq_anf$##dxy]]} - -bind 35 lq_anf$##dxv : {lq_tmp$x##398 : (Tuple int int) | [(lq_tmp$x##398 = ds_dxh)]} -bind 36 lq_anf$##dxv : {lq_tmp$x##404 : (Tuple int int) | [(lq_tmp$x##404 = ds_dxh)]} -bind 37 wink##ax3 : {lq_tmp$x##400 : int | [$k_##259[VV##268:=lq_anf$##dxv][lq_tmp$x##394:=lq_tmp$x##400][VV##258:=lq_tmp$x##400][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##404:=lq_anf$##dxv]]} -bind 38 cow##ax4 : {lq_tmp$x##401 : int | [$k_##262[VV##268:=lq_anf$##dxv][VV##261:=lq_tmp$x##401][lq_tmp$x##409:=wink##ax3][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##395:=lq_tmp$x##401][lq_tmp$x##404:=lq_anf$##dxv]; - $k_##266[lq_tmp$x##396:=wink##ax3][VV##265:=lq_tmp$x##401][lq_tmp$x##264:=wink##ax3][VV##268:=lq_anf$##dxv][lq_tmp$x##397:=lq_tmp$x##401][lq_tmp$x##409:=wink##ax3][lq_tmp$x##403:=lq_tmp$x##401][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##402:=wink##ax3][lq_tmp$x##404:=lq_anf$##dxv]]} -bind 39 lq_anf$##dxv : {lq_tmp$x##404 : (Tuple int int) | [(lq_tmp$x##404 = ds_dxh); - ((snd lq_tmp$x##404) = cow##ax4); - ((fst lq_tmp$x##404) = wink##ax3); - ((x_Tuple22 lq_tmp$x##404) = cow##ax4); - ((x_Tuple21 lq_tmp$x##404) = wink##ax3); - (lq_tmp$x##404 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4)); - ((snd lq_tmp$x##404) = cow##ax4); - ((fst lq_tmp$x##404) = wink##ax3); - ((x_Tuple22 lq_tmp$x##404) = cow##ax4); - ((x_Tuple21 lq_tmp$x##404) = wink##ax3)]} -bind 40 cow##ax4 : {VV##391 : int | [$k_##392]} -bind 41 lq_tmp$x##438 : {VV##439 : int | []} -bind 42 ds_dxi : {lq_tmp$x##422 : (Tuple int int) | [((snd lq_tmp$x##422) = cow##ax4); - ((fst lq_tmp$x##422) = wink##ax3); - ((x_Tuple22 lq_tmp$x##422) = cow##ax4); - ((x_Tuple21 lq_tmp$x##422) = wink##ax3)]} -bind 43 lq_anf$##dxy : {lq_tmp$x##450 : (Tuple int int) | [(lq_tmp$x##450 = ds_dxi)]} -bind 44 lq_anf$##dxy : {lq_tmp$x##456 : (Tuple int int) | [(lq_tmp$x##456 = ds_dxi)]} -bind 45 wink##ax3 : {lq_tmp$x##452 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][VV##427:=lq_tmp$x##452][lq_tmp$x##426:=cow##ax4][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##430:=lq_tmp$x##452][lq_tmp$x##446:=lq_tmp$x##452][lq_tmp$x##422:=lq_anf$##dxy]]} -bind 46 cow##ax4 : {lq_tmp$x##453 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][lq_tmp$x##426:=cow##ax4][VV##431:=lq_tmp$x##453][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##447:=lq_tmp$x##453][lq_tmp$x##461:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxy][lq_tmp$x##434:=lq_tmp$x##453]; - $k_##436[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][lq_tmp$x##426:=cow##ax4][lq_tmp$x##455:=lq_tmp$x##453][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##461:=wink##ax3][lq_tmp$x##438:=wink##ax3][lq_tmp$x##421:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxy][lq_tmp$x##434:=lq_tmp$x##453][lq_tmp$x##448:=wink##ax3][lq_tmp$x##449:=lq_tmp$x##453][VV##435:=lq_tmp$x##453][lq_tmp$x##454:=wink##ax3]]} -bind 47 lq_anf$##dxy : {lq_tmp$x##456 : (Tuple int int) | [(lq_tmp$x##456 = ds_dxi); - ((snd lq_tmp$x##456) = cow##ax4); - ((fst lq_tmp$x##456) = wink##ax3); - ((x_Tuple22 lq_tmp$x##456) = cow##ax4); - ((x_Tuple21 lq_tmp$x##456) = wink##ax3); - (lq_tmp$x##456 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4)); - ((snd lq_tmp$x##456) = cow##ax4); - ((fst lq_tmp$x##456) = wink##ax3); - ((x_Tuple22 lq_tmp$x##456) = cow##ax4); - ((x_Tuple21 lq_tmp$x##456) = wink##ax3)]} -bind 48 wink##awA : {VV##443 : int | [$k_##444]} - -bind 49 lq_anf$##dxx : {lq_tmp$x##480 : (Tuple int int) | [(lq_tmp$x##480 = ds_dxi)]} -bind 50 lq_anf$##dxx : {lq_tmp$x##486 : (Tuple int int) | [(lq_tmp$x##486 = ds_dxi)]} -bind 51 wink##ax3 : {lq_tmp$x##482 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][VV##427:=lq_tmp$x##482][lq_tmp$x##426:=cow##ax4][lq_tmp$x##476:=lq_tmp$x##482][lq_tmp$x##430:=lq_tmp$x##482][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##486:=lq_anf$##dxx]]} -bind 52 cow##ax4 : {lq_tmp$x##483 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][lq_tmp$x##426:=cow##ax4][VV##431:=lq_tmp$x##483][lq_tmp$x##491:=wink##ax3][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##477:=lq_tmp$x##483][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##434:=lq_tmp$x##483][lq_tmp$x##486:=lq_anf$##dxx]; - $k_##436[lq_tmp$x##425:=wink##ax3][lq_tmp$x##426:=cow##ax4][lq_tmp$x##491:=wink##ax3][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##479:=lq_tmp$x##483][lq_tmp$x##485:=lq_tmp$x##483][lq_tmp$x##438:=wink##ax3][lq_tmp$x##421:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##434:=lq_tmp$x##483][lq_tmp$x##484:=wink##ax3][lq_tmp$x##478:=wink##ax3][lq_tmp$x##486:=lq_anf$##dxx][VV##435:=lq_tmp$x##483]]} -bind 53 lq_anf$##dxx : {lq_tmp$x##486 : (Tuple int int) | [(lq_tmp$x##486 = ds_dxi); - ((snd lq_tmp$x##486) = cow##ax4); - ((fst lq_tmp$x##486) = wink##ax3); - ((x_Tuple22 lq_tmp$x##486) = cow##ax4); - ((x_Tuple21 lq_tmp$x##486) = wink##ax3); - (lq_tmp$x##486 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4)); - ((snd lq_tmp$x##486) = cow##ax4); - ((fst lq_tmp$x##486) = wink##ax3); - ((x_Tuple22 lq_tmp$x##486) = cow##ax4); - ((x_Tuple21 lq_tmp$x##486) = wink##ax3)]} -bind 54 cow##awB : {VV##473 : int | [$k_##474]} -bind 55 ds_dxo : {VV##514 : Elim.Foo | []} -bind 56 lq_anf$##dxz : {lq_tmp$x##515 : Elim.Foo | [(lq_tmp$x##515 = ds_dxo)]} -bind 57 lq_anf$##dxz : {lq_tmp$x##517 : Elim.Foo | [(lq_tmp$x##517 = ds_dxo)]} -bind 58 ds_dxp : {lq_tmp$x##525 : int | []} -bind 59 ds_dxq : {lq_tmp$x##526 : int | [(ds_dxp < lq_tmp$x##526)]} -bind 60 lq_anf$##dxz : {lq_tmp$x##517 : Elim.Foo | [(lq_tmp$x##517 = ds_dxo); - ((yy lq_tmp$x##517) = ds_dxq); - ((xx lq_tmp$x##517) = ds_dxp); - (lq_tmp$x##517 = (Elim.Foo##rlA ds_dxp ds_dxq)); - ((yy lq_tmp$x##517) = ds_dxq); - ((xx lq_tmp$x##517) = ds_dxp)]} -bind 61 ds_dxl : {VV##537 : Elim.Foo | []} -bind 62 lq_anf$##dxA : {lq_tmp$x##538 : Elim.Foo | [(lq_tmp$x##538 = ds_dxl)]} -bind 63 lq_anf$##dxA : {lq_tmp$x##540 : Elim.Foo | [(lq_tmp$x##540 = ds_dxl)]} -bind 64 ds_dxm : {lq_tmp$x##548 : int | []} -bind 65 ds_dxn : {lq_tmp$x##549 : int | [(ds_dxm < lq_tmp$x##549)]} -bind 66 lq_anf$##dxA : {lq_tmp$x##540 : Elim.Foo | [(lq_tmp$x##540 = ds_dxl); - ((yy lq_tmp$x##540) = ds_dxn); - ((xx lq_tmp$x##540) = ds_dxm); - (lq_tmp$x##540 = (Elim.Foo##rlA ds_dxm ds_dxn)); - ((yy lq_tmp$x##540) = ds_dxn); - ((xx lq_tmp$x##540) = ds_dxm)]} -bind 67 VV##559 : {VV##559 : int | [(VV##559 = ds_dxm)]} -bind 68 VV##561 : {VV##561 : int | [(VV##561 = ds_dxq)]} -bind 69 VV##563 : {VV##563 : Elim.Foo | [((yy VV##563) = cow##awB); - ((xx VV##563) = wink##awA)]} -bind 70 VV##565 : {VV##565 : int | [(VV##565 = cow##awB)]} -bind 71 VV##567 : {VV##567 : int | [(VV##567 = wink##awA)]} -bind 72 VV##569 : {VV##569 : int | [(VV##569 = cow##ax4)]} -bind 73 VV##571 : {VV##571 : int | [(VV##571 = wink##ax3)]} -bind 74 VV##573 : {VV##573 : int | [(VV##573 = cow##ax4)]} -bind 75 VV##575 : {VV##575 : int | [(VV##575 = wink##ax3)]} -bind 76 VV##577 : {VV##577 : int | [(VV##577 = cow##ax4)]} -bind 77 VV##579 : {VV##579 : int | [(VV##579 = wink##ax3)]} -bind 78 VV##581 : {VV##581 : (Tuple int int) | [$k_##333[VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]} -bind 79 VV##583 : {VV##583 : int | [$k_##323[VV##322:=VV##583][VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]} -bind 80 VV##585 : {VV##585 : int | [$k_##326[VV##325:=VV##585][VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]} -bind 81 lq_tmp$x##264 : {VV##587 : int | []} -bind 82 VV##588 : {VV##588 : int | [$k_##330[VV##332:=VV##581][VV##329:=VV##588][ds_dxg:=GHC.Prim.void###0l][lq_tmp$x##328:=lq_tmp$x##264]]} -bind 83 VV##590 : {VV##590 : GHC.Prim.Void# | [(VV##590 = GHC.Prim.void###0l)]} -bind 84 VV##592 : {VV##592 : (Tuple int int) | [$k_##351[lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##350:=VV##592]]} -bind 85 VV##594 : {VV##594 : int | [$k_##341[lq_tmp$x##353:=VV##594][lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##340:=VV##594][VV##350:=VV##592]]} -bind 86 VV##596 : {VV##596 : int | [$k_##344[lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##343:=VV##596][lq_tmp$x##354:=VV##596][VV##350:=VV##592]]} -bind 87 lq_tmp$x##328 : {VV##598 : int | []} -bind 88 VV##599 : {VV##599 : int | [$k_##348[lq_tmp$x##355:=lq_tmp$x##328][lq_tmp$x##356:=VV##599][VV##347:=VV##599][lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##346:=lq_tmp$x##328][lq_tmp$x##357:=VV##592][VV##350:=VV##592]]} -bind 89 VV##601 : {VV##601 : int | [(VV##601 = lq_anf$##dxu)]} -bind 90 VV##603 : {VV##603 : (Tuple int int) | [((snd VV##603) = cow##ax4); - ((fst VV##603) = wink##ax3); - ((x_Tuple22 VV##603) = cow##ax4); - ((x_Tuple21 VV##603) = wink##ax3)]} -bind 91 VV##605 : {VV##605 : int | [$k_##297[lq_tmp$x##295:=cow##ax4][lq_tmp$x##299:=VV##605][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##296:=VV##605]]} -bind 92 VV##607 : {VV##607 : int | [$k_##301[lq_tmp$x##295:=cow##ax4][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##300:=VV##607][lq_tmp$x##303:=VV##607]]} -bind 93 lq_tmp$x##264 : {VV##609 : int | []} -bind 94 VV##610 : {VV##610 : int | [$k_##305[lq_tmp$x##295:=cow##ax4][lq_tmp$x##290:=lq_tmp$x##264][VV##304:=VV##610][lq_tmp$x##307:=lq_tmp$x##264][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##610]]} -bind 95 VV##612 : {VV##612 : int | [(VV##612 = cow##ax4)]} -bind 96 VV##614 : {VV##614 : int | [(VV##614 = wink##ax3)]} -bind 97 VV##616 : {VV##616 : int | [(VV##616 = yog##awz)]} -bind 98 VV##618 : {VV##618 : int | [(VV##618 = xig##awy)]} -bind 99 VV##473 : {VV##473 : int | [$k_##474]} -bind 100 VV##443 : {VV##443 : int | [$k_##444]} -bind 101 VV##435 : {VV##435 : int | [$k_##436]} -bind 102 VV##431 : {VV##431 : int | [$k_##432]} -bind 103 VV##427 : {VV##427 : int | [$k_##428]} -bind 104 VV##391 : {VV##391 : int | [$k_##392]} -bind 105 VV##361 : {VV##361 : int | [$k_##362]} -bind 106 VV##318 : {VV##318 : GHC.Prim.Void# | [$k_##319]} -bind 107 VV##350 : {VV##350 : (Tuple int int) | [$k_##351]} -bind 108 VV##340 : {VV##340 : int | [$k_##341]} -bind 109 VV##343 : {VV##343 : int | [$k_##344]} -bind 110 lq_tmp$x##346 : {VV##631 : int | []} -bind 111 VV##347 : {VV##347 : int | [$k_##348]} -bind 112 VV##332 : {VV##332 : (Tuple int int) | [$k_##333]} -bind 113 VV##322 : {VV##322 : int | [$k_##323]} -bind 114 VV##325 : {VV##325 : int | [$k_##326]} -bind 115 lq_tmp$x##328 : {VV##636 : int | []} -bind 116 VV##329 : {VV##329 : int | [$k_##330]} -bind 117 VV##304 : {VV##304 : int | [$k_##305]} -bind 118 VV##300 : {VV##300 : int | [$k_##301]} -bind 119 VV##296 : {VV##296 : int | [$k_##297]} -bind 120 VV##268 : {VV##268 : (Tuple int int) | [$k_##269]} -bind 121 VV##258 : {VV##258 : int | [$k_##259]} -bind 122 VV##261 : {VV##261 : int | [$k_##262]} -bind 123 lq_tmp$x##264 : {VV##644 : int | []} -bind 124 VV##265 : {VV##265 : int | [$k_##266]} -bind 125 VV##251 : {VV##251 : int | [$k_##252]} -bind 126 VV##247 : {VV##247 : int | [$k_##248]} - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40; - 42; - 48; - 54 ] - lhs {VV##1 : int | [(VV##1 = cow##awB)]} - rhs {VV##1 : int | [(wink##awA < VV##1)]} - id 1 tag [1] - // META constraint id 1 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40; - 42; - 48; - 49; - 50; - 51; - 52; - 53] - lhs {VV##2 : int | [(VV##2 = cow##ax4)]} - rhs {VV##2 : int | [$k_##474[VV##569:=VV##2][VV##F##2:=VV##2][VV##F:=VV##2][VV##473:=VV##2]]} - id 2 tag [1] - // META constraint id 2 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22] - lhs {VV##18 : (Tuple int int) | [((snd VV##18) = cow##ax4); - ((fst VV##18) = wink##ax3); - ((x_Tuple22 VV##18) = cow##ax4); - ((x_Tuple21 VV##18) = wink##ax3)]} - rhs {VV##18 : (Tuple int int) | [$k_##269[VV##F##18:=VV##18][VV##268:=VV##18][VV##603:=VV##18][VV##F:=VV##18]]} - id 18 tag [1] - // META constraint id 18 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40; - 42; - 43; - 44; - 45; - 46; - 47] - lhs {VV##3 : int | [(VV##3 = wink##ax3)]} - rhs {VV##3 : int | [$k_##444[VV##571:=VV##3][VV##F:=VV##3][VV##F##3:=VV##3][VV##443:=VV##3]]} - id 3 tag [1] - // META constraint id 3 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22; - 90] - lhs {VV##19 : int | [$k_##297[lq_tmp$x##295:=cow##ax4][VV##605:=VV##19][lq_tmp$x##299:=VV##19][lq_tmp$x##291:=VV##603][VV##F##19:=VV##19][lq_tmp$x##294:=wink##ax3][VV##F:=VV##19][VV##296:=VV##19]]} - rhs {VV##19 : int | [$k_##259[VV##605:=VV##19][VV##268:=VV##603][VV##258:=VV##19][VV##F##19:=VV##19][VV##F:=VV##19]]} - id 19 tag [1] - // META constraint id 19 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40] - lhs {VV##4 : int | [(VV##4 = cow##ax4)]} - rhs {VV##4 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][VV##431:=VV##4][VV##573:=VV##4][lq_tmp$x##434:=VV##4][VV##F:=VV##4][VV##F##4:=VV##4]]} - id 4 tag [1] - // META constraint id 4 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22; - 90] - lhs {VV##20 : int | [$k_##301[lq_tmp$x##295:=cow##ax4][VV##607:=VV##20][VV##F##20:=VV##20][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##300:=VV##20][lq_tmp$x##303:=VV##20][VV##F:=VV##20]]} - rhs {VV##20 : int | [$k_##262[VV##268:=VV##603][VV##607:=VV##20][VV##F##20:=VV##20][VV##261:=VV##20][VV##F:=VV##20]]} - id 20 tag [1] - // META constraint id 20 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40] - lhs {VV##5 : int | [(VV##5 = cow##ax4)]} - rhs {VV##5 : int | [$k_##436[lq_tmp$x##425:=wink##ax3][VV##F##5:=VV##5][VV##573:=VV##5][lq_tmp$x##438:=wink##ax3][lq_tmp$x##434:=VV##5][VV##F:=VV##5][VV##435:=VV##5]]} - id 5 tag [1] - // META constraint id 5 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22; - 90; - 93] - lhs {VV##21 : int | [$k_##305[lq_tmp$x##295:=cow##ax4][lq_tmp$x##290:=lq_tmp$x##264][VV##304:=VV##21][VV##610:=VV##21][lq_tmp$x##307:=lq_tmp$x##264][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##21][VV##F##21:=VV##21][VV##F:=VV##21]]} - rhs {VV##21 : int | [$k_##266[VV##265:=VV##21][VV##610:=VV##21][VV##268:=VV##603][VV##F##21:=VV##21][VV##F:=VV##21]]} - id 21 tag [1] - // META constraint id 21 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40] - lhs {VV##6 : int | [(VV##6 = wink##ax3)]} - rhs {VV##6 : int | [$k_##428[VV##F##6:=VV##6][VV##427:=VV##6][lq_tmp$x##430:=VV##6][VV##F:=VV##6][VV##575:=VV##6]]} - id 6 tag [1] - // META constraint id 6 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22] - lhs {VV##22 : int | [(VV##22 = cow##ax4)]} - rhs {VV##22 : int | [$k_##301[VV##F##22:=VV##22][VV##612:=VV##22][lq_tmp$x##294:=wink##ax3][VV##300:=VV##22][lq_tmp$x##303:=VV##22][VV##F:=VV##22]]} - id 22 tag [1] - // META constraint id 22 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 35; - 36; - 37; - 38; - 39] - lhs {VV##7 : int | [(VV##7 = cow##ax4)]} - rhs {VV##7 : int | [$k_##392[VV##391:=VV##7][VV##F##7:=VV##7][VV##F:=VV##7][VV##577:=VV##7]]} - id 7 tag [1] - // META constraint id 7 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22] - lhs {VV##23 : int | [(VV##23 = cow##ax4)]} - rhs {VV##23 : int | [$k_##305[VV##304:=VV##23][lq_tmp$x##307:=wink##ax3][VV##612:=VV##23][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##23][VV##F:=VV##23][VV##F##23:=VV##23]]} - id 23 tag [1] - // META constraint id 23 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 29; - 30; - 31; - 32; - 33] - lhs {VV##8 : int | [(VV##8 = wink##ax3)]} - rhs {VV##8 : int | [$k_##362[VV##579:=VV##8][VV##F##8:=VV##8][VV##361:=VV##8][VV##F:=VV##8]]} - id 8 tag [1] - // META constraint id 8 : () - - -constraint: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22] - lhs {VV##24 : int | [(VV##24 = wink##ax3)]} - rhs {VV##24 : int | [$k_##297[lq_tmp$x##299:=VV##24][VV##614:=VV##24][VV##F:=VV##24][VV##296:=VV##24][VV##F##24:=VV##24]]} - id 24 tag [1] - // META constraint id 24 : () - - -constraint: - env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] - lhs {VV##25 : int | [(VV##25 = yog##awz)]} - rhs {VV##25 : int | [$k_##252[VV##251:=VV##25][lq_tmp$x##254:=VV##25][lq_tmp$x##245:=xig##awy][VV##F:=VV##25][VV##616:=VV##25][VV##F##25:=VV##25]]} - id 25 tag [1] - // META constraint id 25 : () - - -constraint: - env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] - lhs {VV##26 : int | [(VV##26 = xig##awy)]} - rhs {VV##26 : int | [$k_##248[VV##618:=VV##26][VV##247:=VV##26][VV##F##26:=VV##26][VV##F:=VV##26][lq_tmp$x##250:=VV##26]]} - id 26 tag [1] - // META constraint id 26 : () - - - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 115] - reft {VV##329 : int | [$k_##330]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25] - reft {VV##318 : GHC.Prim.Void# | [$k_##319]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 27; - 107] - reft {VV##343 : int | [$k_##344]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40] - reft {VV##427 : int | [$k_##428]} - // META wf : () - - -wf: - env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] - reft {VV##247 : int | [$k_##248]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40; - 41] - reft {VV##435 : int | [$k_##436]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40; - 42] - reft {VV##443 : int | [$k_##444]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22] - reft {VV##296 : int | [$k_##297]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 27; - 110] - reft {VV##347 : int | [$k_##348]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40; - 42; - 48] - reft {VV##473 : int | [$k_##474]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 27] - reft {VV##350 : (Tuple int int) | [$k_##351]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34] - reft {VV##391 : int | [$k_##392]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26] - reft {VV##332 : (Tuple int int) | [$k_##333]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 120] - reft {VV##258 : int | [$k_##259]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 120] - reft {VV##261 : int | [$k_##262]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 27; - 107] - reft {VV##340 : int | [$k_##341]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22; - 23] - reft {VV##304 : int | [$k_##305]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 112] - reft {VV##325 : int | [$k_##326]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28] - reft {VV##361 : int | [$k_##362]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 123] - reft {VV##265 : int | [$k_##266]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 24; - 25; - 26; - 112] - reft {VV##322 : int | [$k_##323]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 18; - 19; - 20; - 21; - 22] - reft {VV##300 : int | [$k_##301]} - // META wf : () - - -wf: - env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17] - reft {VV##268 : (Tuple int int) | [$k_##269]} - // META wf : () - - -wf: - env [0; - 1; - 2; - 3; - 4; - 5; - 6; - 7; - 8; - 9; - 10; - 11; - 12; - 13; - 14; - 15; - 16; - 17; - 28; - 34; - 40] - reft {VV##431 : int | [$k_##432]} - // META wf : () - - -wf: - env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] - reft {VV##251 : int | [$k_##252]} - // META wf : () diff --git a/tests/elim/kvparam00.fq b/tests/elim/kvparam00.fq deleted file mode 100644 --- a/tests/elim/kvparam00.fq +++ /dev/null @@ -1,20 +0,0 @@ -bind 0 x : {v : int | []} - -bind 1 y : {v : int | []} - -constraint: - env [0; 1] - lhs {VV#F1 : int | []} - rhs {VV#F1 : int | [$k_0[v:=x]]} - id 1 tag [3] - -constraint: - env [0; 1] - lhs {VV#F2 : int | [$k_0[v:=y]]} - rhs {VV#F2 : int | [y = x]} - id 2 tag [4] - -wf: - env [] - reft {v : int | [$k_0]} - diff --git a/tests/elim/len00.fq b/tests/elim/len00.fq deleted file mode 100644 --- a/tests/elim/len00.fq +++ /dev/null @@ -1,23 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif ListZ(v : [@(0)]): (len v >= 0) - -constant len : (func(2, [(@(0) @(1)); int])) - -bind 0 y : {v : [(Tuple int a)] | [len v >= 0]} - -constraint: - env [0] - lhs {v : [(Tuple int a)] | [v = y] } - rhs {v : [(Tuple int a)] | [$k0] } - id 1 tag [] - -constraint: - env [] - lhs {v : [(Tuple int a)] | [$k0] } - rhs {v : [(Tuple int a)] | [len v >= 0] } - id 2 tag [] - -wf: - env [ ] - reft {v : [(Tuple int a)] | [$k0] } diff --git a/tests/elim/test00-tx.fq b/tests/elim/test00-tx.fq deleted file mode 100644 --- a/tests/elim/test00-tx.fq +++ /dev/null @@ -1,12 +0,0 @@ - - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 a : {v:int | (v = 10 || v = 20) } - -constraint: - env [ 0 ] - lhs {v : int | v = a} - rhs {v : int | 10 <= v} - id 3 tag [] diff --git a/tests/elim/test00.fq b/tests/elim/test00.fq deleted file mode 100644 --- a/tests/elim/test00.fq +++ /dev/null @@ -1,26 +0,0 @@ -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 a : {v: int | $k0} - -constraint: - env [ ] - lhs {v : int | v = 10} - rhs {v : int | $k0} - id 1 tag [] - -constraint: - env [ ] - lhs {v : int | v = 20} - rhs {v : int | $k0} - id 2 tag [] - -constraint: - env [ 0 ] - lhs {v : int | v = a} - rhs {v : int | 10 <= v} - id 3 tag [] - -wf: - env [ ] - reft {v: int | $k0} diff --git a/tests/elim/test00a.fq b/tests/elim/test00a.fq deleted file mode 100644 --- a/tests/elim/test00a.fq +++ /dev/null @@ -1,28 +0,0 @@ -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 x : {v : int | true} -bind 1 y : {v : int | true} -bind 2 z : {v : int | true} - -constraint: - env [0] - lhs {v : int | (x = 10)} - rhs {v : int | $k0[v:=x]} - id 1 tag [] - -constraint: - env [1] - lhs {v : int | y = 20} - rhs {v : int | $k0[v:=y]} - id 2 tag [] - -constraint: - env [2] - lhs {v : int | $k0[v:=z]} - rhs {v : int | 10 <= z} - id 3 tag [] - -wf: - env [ ] - reft {v: int | $k0} diff --git a/tests/elim/test1.fq b/tests/elim/test1.fq deleted file mode 100644 --- a/tests/elim/test1.fq +++ /dev/null @@ -1,29 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a) : (10 <= v) - -bind 0 x : {v : int | v = 10} -bind 1 y : {v : int | v = 20} -bind 2 a : {v : int | $k0 } - -constraint: - env [0] - lhs {v : int | v = x} - rhs {v : int | $k0 } - id 1 tag [] - -constraint: - env [1] - lhs {v : int | v = y} - rhs {v : int | $k0 } - id 2 tag [] - -constraint: - env [2] - lhs {v : int | v = a } - rhs {v : int | 10 <= v} - id 3 tag [] - -wf: - env [ ] - reft {v : int | $k0} diff --git a/tests/elim/test2.fq b/tests/elim/test2.fq deleted file mode 100644 --- a/tests/elim/test2.fq +++ /dev/null @@ -1,53 +0,0 @@ - -// This qualifier saves the day; solve constraints WITHOUT IT -// qualif Zog(v:a): (10 <= v) - -// But you may use this one -qualif Pog(v:a): (0 <= v) - -bind 0 x: {v: int | v = 10} -bind 1 a: {v: int | $k1 } -bind 2 y: {v: int | v = 20} -bind 3 b: {v: int | $k1 } -bind 4 c: {v: int | $k0 } - -cut $k1 - -constraint: - env [ ] - lhs {v : int | v = 0} - rhs {v : int | $k1 } - id 0 tag [] - - -constraint: - env [0; 1] - lhs {v : int | v = x + a} - rhs {v : int | $k0} - id 1 tag [] - -constraint: - env [2; 3] - lhs {v : int | v = y + b} - rhs {v : int | $k0} - id 2 tag [] - -constraint: - env [ ] - lhs {v : int | $k0} - rhs {v : int | $k1} - id 3 tag [] - -constraint: - env [4] - lhs {v : int | v = c } - rhs {v : int | 10 <= v} - id 4 tag [] - -wf: - env [ ] - reft {v: int | $k0} - -wf: - env [ ] - reft {v: int | $k1} diff --git a/tests/elim/tuple00.fq b/tests/elim/tuple00.fq deleted file mode 100644 --- a/tests/elim/tuple00.fq +++ /dev/null @@ -1,114 +0,0 @@ - -bind 0 cat : {v: int | v = 100 } -bind 1 dog : {v: int | v = 200 } -bind 2 frog : {v: int | v = 400 } -bind 3 mouse : {v: int | v = 500 } -bind 4 hippo : {v: int | v = 600 } -bind 5 goose : {v: int | v = 700 } -bind 6 crow : {v: int | v = 800 } -bind 7 pig : {v: int | v = 900 } - -bind 20 x_1_1 : {v: int | $k_1_1 } -bind 21 x_1_2 : {v: int | $k_1_2 } -bind 22 x_2_1 : {v: int | $k_2_1 } -bind 23 x_2_2 : {v: int | $k_2_2 } -bind 24 x_3_1 : {v: int | $k_3_1 } -bind 25 x_3_2 : {v: int | $k_3_2 } - -pack $k_1_1 : 1 -pack $k_1_2 : 1 -pack $k_2_1 : 2 -pack $k_2_2 : 2 -pack $k_3_1 : 3 -pack $k_3_2 : 3 -pack $k_4_1 : 4 -pack $k_4_2 : 4 - - - -constraint: - env [ 0; 1; 2; 3; 4; 5; 6; 7 ] - lhs {v : int | v = 1} - rhs {v : int | $k_1_1} - id 1 tag [] - -constraint: - env [ 0; 1; 2; 3; 4; 5; 6; 7 ] - lhs {v : int | v = 2} - rhs {v : int | $k_1_2} - id 2 tag [] - -constraint: - env [ 20; 21 ] - lhs {v : int | v = x_1_1 } - rhs {v : int | $k_2_1 } - id 3 tag [] - -constraint: - env [ 20; 21 ] - lhs {v : int | v = x_1_2 } - rhs {v : int | $k_2_2 } - id 4 tag [] - -constraint: - env [ 22; 23 ] - lhs {v : int | v = x_2_1 } - rhs {v : int | $k_3_1 } - id 5 tag [] - -constraint: - env [ 22; 23 ] - lhs {v : int | v = x_2_2 } - rhs {v : int | $k_3_2 } - id 6 tag [] - -constraint: - env [ 24; 25 ] - lhs {v : int | v = x_3_1 } - rhs {v : int | $k_4_1 } - id 7 tag [] - -constraint: - env [ 24; 25 ] - lhs {v : int | v = x_3_2 } - rhs {v : int | $k_4_2 } - id 8 tag [] - -constraint: - env [ ] - lhs {v : int | $k_4_1 } - rhs {v : int | v = 1 } - id 9 tag [] - -wf: - env [ ] - reft {v: int | $k_1_1} - -wf: - env [ ] - reft {v: int | $k_1_2} - -wf: - env [ ] - reft {v: int | $k_2_1} - -wf: - env [ ] - reft {v: int | $k_2_2} - -wf: - env [ ] - reft {v: int | $k_3_1} - -wf: - env [ ] - reft {v: int | $k_3_2} - - -wf: - env [ ] - reft {v: int | $k_4_1} - -wf: - env [ ] - reft {v: int | $k_4_2} diff --git a/tests/elim/tuple01.fq b/tests/elim/tuple01.fq deleted file mode 100644 --- a/tests/elim/tuple01.fq +++ /dev/null @@ -1,137 +0,0 @@ -// This test illustrates how you can get an exponential VC from nested tuples - -bind 0 cat : {v: int | v = 100 } -bind 1 dog : {v: int | v = 200 } -bind 2 frog : {v: int | v = 400 } -bind 3 mouse : {v: int | v = 500 } -bind 4 hippo : {v: int | v = 600 } -bind 5 goose : {v: int | v = 700 } -bind 6 crow : {v: int | v = 800 } -bind 7 pig : {v: int | v = 900 } - -bind 20 x_1_1 : {v: int | $k_1_1 } -bind 21 x_1_2 : {v: int | $k_1_2 } -bind 22 x_2_1 : {v: int | $k_2_1 } -bind 23 x_2_2 : {v: int | $k_2_2 } -bind 24 x_3_1 : {v: int | $k_3_1 } -bind 25 x_3_2 : {v: int | $k_3_2 } -bind 26 x_4_1 : {v: int | $k_4_1 } -bind 27 x_4_2 : {v: int | $k_4_2 } - -// pack $k_1_1 : 1 -// pack $k_1_2 : 1 -// pack $k_2_1 : 2 -// pack $k_2_2 : 2 -// pack $k_3_1 : 3 -// pack $k_3_2 : 3 -// pack $k_4_1 : 4 -// pack $k_4_2 : 4 -// pack $k_5_1 : 5 -// pack $k_5_2 : 5 - -constraint: - env [ 0; 1; 2; 3; 4; 5; 6; 7 ] - lhs {v : int | v = 1} - rhs {v : int | $k_1_1} - id 1 tag [] - -constraint: - env [ 0; 1; 2; 3; 4; 5; 6; 7 ] - lhs {v : int | v = 2} - rhs {v : int | $k_1_2} - id 2 tag [] - -constraint: - env [ 20; 21 ] - lhs {v : int | v = x_1_1 } - rhs {v : int | $k_2_1 } - id 3 tag [] - -constraint: - env [ 20; 21 ] - lhs {v : int | v = x_1_2 } - rhs {v : int | $k_2_2 } - id 4 tag [] - -constraint: - env [ 22; 23 ] - lhs {v : int | v = x_2_1 } - rhs {v : int | $k_3_1 } - id 5 tag [] - -constraint: - env [ 22; 23 ] - lhs {v : int | v = x_2_2 } - rhs {v : int | $k_3_2 } - id 6 tag [] - -constraint: - env [ 24; 25 ] - lhs {v : int | v = x_3_1 } - rhs {v : int | $k_4_1 } - id 7 tag [] - -constraint: - env [ 24; 25 ] - lhs {v : int | v = x_3_2 } - rhs {v : int | $k_4_2 } - id 8 tag [] - -constraint: - env [ 26; 27 ] - lhs {v : int | v = x_4_1 } - rhs {v : int | $k_5_1 } - id 9 tag [] - -constraint: - env [ 26; 27 ] - lhs {v : int | v = x_4_2 } - rhs {v : int | $k_5_2 } - id 10 tag [] - -constraint: - env [ ] - lhs {v : int | $k_5_1 } - rhs {v : int | v = 1 } - id 11 tag [] - -wf: - env [ ] - reft {v: int | $k_1_1} - -wf: - env [ ] - reft {v: int | $k_1_2} - -wf: - env [ ] - reft {v: int | $k_2_1} - -wf: - env [ ] - reft {v: int | $k_2_2} - -wf: - env [ ] - reft {v: int | $k_3_1} - -wf: - env [ ] - reft {v: int | $k_3_2} - - -wf: - env [ ] - reft {v: int | $k_4_1} - -wf: - env [ ] - reft {v: int | $k_4_2} - -wf: - env [ ] - reft {v: int | $k_5_1} - -wf: - env [ ] - reft {v: int | $k_5_2} diff --git a/tests/horn/neg/abs02-re.smt2 b/tests/horn/neg/abs02-re.smt2 deleted file mode 100644 --- a/tests/horn/neg/abs02-re.smt2 +++ /dev/null @@ -1,29 +0,0 @@ -(fixpoint "--eliminate=horn") - -(var $k_##1 ((Int) (Int))) -(var $k_##3 ((Int) (Int))) - -(constraint - (and - (forall ((x int) (true)) - (forall ((pos bool) (pos <=> x >= 0)) - (and - (forall ((lq_tmp$grd##3 bool) (pos)) - (forall ((VV int) (VV == x)) - (($k_##1 VV x)))) - (forall ((lq_tmp$grd##3 bool) (not pos)) - (forall ((v int) (v == 0 - x)) - (($k_##1 v x))))))) - (forall ((z int) (true)) - (and - (forall ((r int) (r >= 0)) - (forall ((v int) (v == r + 1)) - (($k_##3 v z)))) - (and - (forall ((_t1 int) (_t1 >= 0)) - (forall ((VV##0 int) ($k_##1 VV##0 _t1)) - (((VV##0 >= 0))))) - (forall ((res int) ($k_##3 res z)) - (forall ((ok bool) (ok <=> 6660 <= res)) - (forall ((v bool) ((v <=> 6660 <= res) && v == ok)) - ((v)))))))))) diff --git a/tests/horn/neg/ebind03.smt2 b/tests/horn/neg/ebind03.smt2 deleted file mode 100644 --- a/tests/horn/neg/ebind03.smt2 +++ /dev/null @@ -1,16 +0,0 @@ -(fixpoint "--eliminate=horn") - -(var $ka ((Int))) -(var $kb ((Int))) - -(constraint -(and - (exists ((x1 Int) (true)) - (and - (forall ((v Int) (v = 1)) ((v = x1))) - (forall ((v Int) (v = x1 + 1)) (($ka v))))) - (exists ((x2 Int) (true)) - (and - (forall ((v Int) ($ka v)) ((v = x2))) - (forall ((v Int) (v = x2 + 1)) (($kb v))))) - (forall ((v Int) ($kb v)) ((v = 5))))) diff --git a/tests/horn/neg/irregular_adt_00.smt2 b/tests/horn/neg/irregular_adt_00.smt2 deleted file mode 100644 --- a/tests/horn/neg/irregular_adt_00.smt2 +++ /dev/null @@ -1,36 +0,0 @@ -// we want this to fail because FingerTree is NOT a 'regular' datatype. See `isRegularDataDecl` - -(data Node 1 = [ - | Node3 {Node3_lqdc_select_Node3_1 : @(0), Node3_lqdc_select_Node3_2 : @(0), Node3_lqdc_select_Node3_3 : @(0)} - | Node2 {Node2_lqdc_select_Node2_1 : @(0), Node2_lqdc_select_Node2_2 : @(0)} -]) - -(data Digit 1 = [ - | Four {Four_lqdc_select_Four_1 : @(0), Four_lqdc_select_Four_2 : @(0), Four_lqdc_select_Four_3 : @(0), Four_lqdc_select_Four_4 : @(0)} - | Three {Three_lqdc_select_Three_1 : @(0), Three_lqdc_select_Three_2 : @(0), Three_lqdc_select_Three_3 : @(0)} - | Two {Two_lqdc_select_Two_1 : @(0), Two_lqdc_select_Two_2 : @(0)} - | One {One_lqdc_select_One_1 : @(0)} -]) - -(data FingerTree 1 = [ - | Deep {Deep_lqdc_select_Deep_1 : (Digit @(0)), Deep_lqdc_select_Deep_2 : (FingerTree (Node @(0))), Deep_lqdc_select_Deep_3 : (Digit @(0))} - | Single {Single_lqdc_select_Single_1 : @(0)} - | EmptyT {} -]) - - -(constant len (func(1, [(FingerTree @(0)), int]))) - -(define len(l: [a]) : int = { - if (is$VNil l) then 0 else (1 + len(tail l)) -}) - -(constraint - (forall ((x (FingerTree int)) (true)) - (forall ((y (FingerTree int)) (y = x)) - (forall ((z (FingerTree int)) (z = y)) - (((len z) == (len x))) - ) - ) - ) -) diff --git a/tests/horn/neg/ple0.smt2 b/tests/horn/neg/ple0.smt2 deleted file mode 100644 --- a/tests/horn/neg/ple0.smt2 +++ /dev/null @@ -1,13 +0,0 @@ -(fixpoint "--rewrite") - -(constant adder (func(0, [int, int, int]))) - -(define adder(x : int, y : int) : int = { x + y }) - -(constraint - (forall ((x int) (x == 5)) - (forall ((y int) (y == 6)) - (( (adder x y) = 12 )) - ) - ) -) diff --git a/tests/horn/neg/ple_list00.smt2 b/tests/horn/neg/ple_list00.smt2 deleted file mode 100644 --- a/tests/horn/neg/ple_list00.smt2 +++ /dev/null @@ -1,12 +0,0 @@ -(fixpoint "--rewrite") - -(constant len (func(1, [(Main.List @(0)), int]))) -(constant Cons (func(2, [@(0), (Main.List @(0)), (Main.List @(0))]))) -(constant Nil (Main.List @(0))) - -(match len Nil = 0) -(match len Cons x xs = (1 + len xs)) - -(constraint - ((len (Cons 1 (Cons 2 (Cons 3 Nil))) = 4)) -) diff --git a/tests/horn/neg/ple_list01_adt.smt2 b/tests/horn/neg/ple_list01_adt.smt2 deleted file mode 100644 --- a/tests/horn/neg/ple_list01_adt.smt2 +++ /dev/null @@ -1,22 +0,0 @@ -(fixpoint "--rewrite") - -(data Vec 1 = [ - | VNil { } - | VCons { head : @(0), tail : Vec @(0)} -]) - -(constant len (func(1, [(Vec @(0)), int]))) - -(define len(l: [a]) : int = { - if (is$VNil l) then 0 else (1 + len(tail l)) -}) - -(constraint - (forall ((x int) (true)) - (forall ((y int) (y = 2)) - (forall ((z int) (z = 3)) - ((len (VCons x (VCons y (VCons z VNil))) = 30)) - ) - ) - ) -) diff --git a/tests/horn/neg/ple_list03.smt2 b/tests/horn/neg/ple_list03.smt2 deleted file mode 100644 --- a/tests/horn/neg/ple_list03.smt2 +++ /dev/null @@ -1,45 +0,0 @@ -(fixpoint "--rewrite") - -(define ints2 (): [int] = { - Cons 1 (Cons 20 Nil) -}) - -(define filter (lq1 : func(0 , [a##a29r;bool]), lq2 : [a##a29r]) : [a##a29r] = { - if (isNil lq2) then Nil else ( - if (lq1 (head lq2)) - then (Cons (head lq2) (filter lq1 (tail lq2))) - else (filter lq1 (tail lq2))) -}) - -(define ints0 () : [int] = { - Cons 0 (Cons 1 (Cons 2 Nil)) -}) - -(define isPos (lq1 : int) : bool = { - lq1 > 0 -}) - - -(match isCons Cons x xs = (true)) -(match isNil Cons x xs = (false)) -(match isCons Nil = (false)) -(match isNil Nil = (true)) -(match tail Cons x xs = (xs)) -(match head Cons x xs = (x)) - -(constant isCons (func(1 , [[@(0)], bool]))) -(constant isNil (func(1 , [[@(0)], bool]))) -(constant Nil (func(1 , [[@(0)]]))) -(constant tail (func(1 , [[@(0)], [@(0)]]))) -(constant head (func(1 , [[@(0)], @(0)]))) -(constant ints0 [int]) -(constant ints2 [int]) -(constant filter (func(1 , [func(0 , [@(0), bool]), [@(0)], [@(0)]]))) - -(constant isPos (func(0 , [int, bool]))) -(constant Cons (func(1 , [@(0), [@(0)], [@(0)]]))) -(constant Nil (func(1 , [[@(0)]]))) - -(constraint - ((filter isPos ints0 == ints2)) -) diff --git a/tests/horn/neg/ple_sum.smt2 b/tests/horn/neg/ple_sum.smt2 deleted file mode 100644 --- a/tests/horn/neg/ple_sum.smt2 +++ /dev/null @@ -1,12 +0,0 @@ -(fixpoint "--rewrite") - -(constant sum (func(0, [int, int]))) - -(define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) }) - -(constraint - (forall ((x int) (x == 5)) - (( (sum x) = 150 )) - ) -) - diff --git a/tests/horn/neg/ple_sum_fuel.5.smt2 b/tests/horn/neg/ple_sum_fuel.5.smt2 deleted file mode 100644 --- a/tests/horn/neg/ple_sum_fuel.5.smt2 +++ /dev/null @@ -1,14 +0,0 @@ -(fixpoint "--rewrite") -(fixpoint "--save") -(fixpoint "--fuel=5") - -(constant sum (func(0, [int, int]))) - -(define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) }) - -(constraint - (forall ((x int) ((5 <= x) && (0 <= (sum (x-5))))) - ((15 <= (sum x))) - ) -) - diff --git a/tests/horn/neg/tag00.smt2 b/tests/horn/neg/tag00.smt2 deleted file mode 100644 --- a/tests/horn/neg/tag00.smt2 +++ /dev/null @@ -1,16 +0,0 @@ -(fixpoint "--eliminate=horn") - -// TODO move to actual SMTLIB format - -(constraint -(forall ((x Int) (x > 0)) - (and - (forall ((y Int) (y > x)) - (forall ((v Int) (v = x + y)) - ( (v > 0) ))) - (forall ((z Int) (z > 10)) - (forall ((v Int) (v = x + z)) - (tag (v > 100) "gt-100" ))))) -) - - diff --git a/tests/horn/neg/test00.smt2 b/tests/horn/neg/test00.smt2 deleted file mode 100644 --- a/tests/horn/neg/test00.smt2 +++ /dev/null @@ -1,10 +0,0 @@ -(fixpoint "--eliminate=horn") - -// TODO move to actual SMTLIB format - -(constraint -(forall ((x Int) (x > 0)) - (forall ((y Int) (y > x)) - (forall ((v Int) (v = x + y)) - ((v > 10))))) -) diff --git a/tests/horn/neg/test01.smt2 b/tests/horn/neg/test01.smt2 deleted file mode 100644 --- a/tests/horn/neg/test01.smt2 +++ /dev/null @@ -1,16 +0,0 @@ -(fixpoint "--eliminate=horn") - -// TODO move to actual SMTLIB format - -(constraint -(forall ((x Int) (x > 0)) - (and - (forall ((y Int) (y > x)) - (forall ((v Int) (v = x + y)) - ( (v > 0) ))) - (forall ((z Int) (z > 10)) - (forall ((v Int) (v = x + z)) - (tag (v > 100) "gt-100" ))))) -) - - diff --git a/tests/horn/neg/test02.smt2 b/tests/horn/neg/test02.smt2 deleted file mode 100644 --- a/tests/horn/neg/test02.smt2 +++ /dev/null @@ -1,18 +0,0 @@ -(fixpoint "--eliminate=horn") - -// TODO move to actual SMTLIB format - -(var $k0 ((Int))) - -(qualif Foo ((v Int)) ((v > 100))) - -(constraint - (forall ((x Int) (x > 0)) - (and - (forall ((y Int) (y > x + 100)) - (forall ((v Int) (v = x + y)) - (($k0 v)))) - (forall ((z Int) ($k0 z)) - (forall ((v Int) (v = x + z)) - ((v > 200))))))) - diff --git a/tests/horn/neg/test03.smt2 b/tests/horn/neg/test03.smt2 deleted file mode 100644 --- a/tests/horn/neg/test03.smt2 +++ /dev/null @@ -1,24 +0,0 @@ -(fixpoint "--eliminate=horn") - -// TODO move to actual SMTLIB format - -(var $k0 ((Int))) - -(qualif Foo ((v Int)) ((v > 10))) - -(constraint - (and - (forall ((x Int) (x > 0)) - (forall ((v Int) (v = x)) - (($k0 v)))) - (forall ((y Int) ($k0 y)) - (forall ((v Int) (v = y + 1)) - (($k0 v)))) - (forall ((z Int) ($k0 z)) - ((z > 0))))) - - - - - - diff --git a/tests/horn/pos/abs02-re.smt2 b/tests/horn/pos/abs02-re.smt2 deleted file mode 100644 --- a/tests/horn/pos/abs02-re.smt2 +++ /dev/null @@ -1,13 +0,0 @@ -(constraint - (and - (forall ((x int) (true)) - (forall ((VV int) (VV == 10)) - ((VV >= 0)))) - (forall ((z int) (true)) - (and - (forall ((r int) (r >= 0)) - (forall ((v int) (v >= 0 && v == r)) - (((v >= 0))))) - (forall ((_t1 int) (_t1 >= 0)) - (forall ((v int) (v >= 0)) - (((v >= 0))))))))) diff --git a/tests/horn/pos/constant.smt2 b/tests/horn/pos/constant.smt2 deleted file mode 100644 --- a/tests/horn/pos/constant.smt2 +++ /dev/null @@ -1,13 +0,0 @@ -(var $k0 ((Int))) - -(qualif Foo ((v Int)) ((v > 100))) - -(constraint - (forall ((x Int) (x > 0)) - (and - (forall ((v Int) (v = f x)) - (($k0 v))) - (forall ((z Int) ($k0 z)) - ((z = f x)))))) - -(constant f (func(0, [Int;Int]))) diff --git a/tests/horn/pos/ebind01.smt2 b/tests/horn/pos/ebind01.smt2 deleted file mode 100644 --- a/tests/horn/pos/ebind01.smt2 +++ /dev/null @@ -1,6 +0,0 @@ -(constraint - (forall ((m Int) (true)) - (exists ((x1 Int) (true)) - (and - (forall ((v Int) (v = m + 1)) ((v = x1))) - (forall ((v Int) (v = x1 + 1)) ((v = 2 + m))))))) diff --git a/tests/horn/pos/ebind02.smt2 b/tests/horn/pos/ebind02.smt2 deleted file mode 100644 --- a/tests/horn/pos/ebind02.smt2 +++ /dev/null @@ -1,11 +0,0 @@ -(var $k ((Int))) - -(constraint - (forall ((m Int) (true)) - (forall ((z Int) (z = m - 1)) - (and - (forall ((v1 Int) (v1 = z + 2)) (($k v1))) - (exists ((x1 Int) (true)) - (and - (forall ((v2 Int) ($k v2)) ((v2 = x1))) - (forall ((v3 Int) (v3 = x1 + 1)) ((v3 = m + 2))))))))) diff --git a/tests/horn/pos/ebind03.smt2 b/tests/horn/pos/ebind03.smt2 deleted file mode 100644 --- a/tests/horn/pos/ebind03.smt2 +++ /dev/null @@ -1,14 +0,0 @@ -(var $ka ((Int))) -(var $kb ((Int))) - -(constraint -(and - (exists ((x1 Int) (true)) - (and - (forall ((v Int) (v = 1)) ((v = x1))) - (forall ((v Int) (v = x1 + 1)) (($ka v))))) - (exists ((x2 Int) (true)) - (and - (forall ((v Int) ($ka v)) ((v = x2))) - (forall ((v Int) (v = x2 + 1)) (($kb v))))) - (forall ((v Int) ($kb v)) ((v = 3))))) diff --git a/tests/horn/pos/icfp17-ex1.smt2 b/tests/horn/pos/icfp17-ex1.smt2 deleted file mode 100644 --- a/tests/horn/pos/icfp17-ex1.smt2 +++ /dev/null @@ -1,14 +0,0 @@ -(fixpoint "--eliminate=horn") - -(var $k ((Int))) - -(constraint - (forall ((x Int) (x >= 0)) - (and - (forall ((v Int) (v = x - 1)) - (($k v))) - (forall ((y Int) ($k y)) - (forall ((v Int) (v = y + 1)) - ((v >= 0))))))) - - diff --git a/tests/horn/pos/icfp17-ex2.smt2 b/tests/horn/pos/icfp17-ex2.smt2 deleted file mode 100644 --- a/tests/horn/pos/icfp17-ex2.smt2 +++ /dev/null @@ -1,19 +0,0 @@ -(fixpoint "--eliminate=horn") - -(var $kx ((Int))) -(var $ky ((Int))) - -(constraint - (forall ((x Int) (x >= 0)) - (and - (forall ((n Int) (n = x - 1)) - (forall ((p Int) (p = x + 1)) - (and - (forall ((v Int) (v = n)) (($kx v))) - (forall ((v Int) (v = p)) (($ky v))) - (forall ((v Int) ($kx p)) (($ky v)))))) - (forall ((y Int) ($ky y)) - (forall ((v Int) (v = y + 1)) - ((v >= 0))))))) - - diff --git a/tests/horn/pos/icfp17-ex3.smt2 b/tests/horn/pos/icfp17-ex3.smt2 deleted file mode 100644 --- a/tests/horn/pos/icfp17-ex3.smt2 +++ /dev/null @@ -1,16 +0,0 @@ -(fixpoint "--eliminate=horn") - -(var $ka ((Int))) -(var $kb ((Int))) -(var $kc ((Int))) - -(constraint - (and - (forall ((a Int) ($ka a)) - (forall ((v Int) (v = a - 1)) (($kb v)))) - (forall ((b Int) ($kb b)) - (forall ((v Int) (v = b + 1)) - (($kc v)))) - (forall ((v Int) (v >= 0)) (($ka v))) - (forall ((v Int) ($kc v)) ((v >= 0))))) - diff --git a/tests/horn/pos/ple0.smt2 b/tests/horn/pos/ple0.smt2 deleted file mode 100644 --- a/tests/horn/pos/ple0.smt2 +++ /dev/null @@ -1,13 +0,0 @@ -(fixpoint "--rewrite") - -(constant adder (func(0, [int, int, int]))) - -(define adder(x : int, y : int) : int = { x + y }) - -(constraint - (forall ((x int) (x == 5)) - (forall ((y int) (y == 6)) - (( (adder x y) = 11 )) - ) - ) -) diff --git a/tests/horn/pos/ple_list00.smt2 b/tests/horn/pos/ple_list00.smt2 deleted file mode 100644 --- a/tests/horn/pos/ple_list00.smt2 +++ /dev/null @@ -1,18 +0,0 @@ -(fixpoint "--rewrite") - -(constant len (func(1, [(MyList @(0)), int]))) -(constant Cons (func(2, [@(0), (MyList @(0)), (MyList @(0))]))) -(constant Nil (MyList @(0))) - -(match len Nil = 0) -(match len Cons x xs = (1 + len xs)) - -(constraint - (forall ((x int) (true)) - (forall ((y int) (y = 2)) - (forall ((z int) (z = 3)) - ((len (Cons x (Cons y (Cons z Nil))) = 3)) - ) - ) - ) -) diff --git a/tests/horn/pos/ple_list01_adt.smt2 b/tests/horn/pos/ple_list01_adt.smt2 deleted file mode 100644 --- a/tests/horn/pos/ple_list01_adt.smt2 +++ /dev/null @@ -1,23 +0,0 @@ -(fixpoint "--rewrite") -(fixpoint "--save") - -(data Vec 1 = [ - | VNil { } - | VCons { head : @(0), tail : Vec @(0)} -]) - -(constant len (func(1, [(Vec @(0)), int]))) - -(define len(l: [a]) : int = { - if (is$VNil l) then 0 else (1 + len(tail l)) -}) - -(constraint - (forall ((x int) (true)) - (forall ((y int) (y = 2)) - (forall ((z int) (z = 3)) - ((len (VCons x (VCons y (VCons z VNil))) = 3)) - ) - ) - ) -) diff --git a/tests/horn/pos/ple_sum.smt2 b/tests/horn/pos/ple_sum.smt2 deleted file mode 100644 --- a/tests/horn/pos/ple_sum.smt2 +++ /dev/null @@ -1,13 +0,0 @@ -(fixpoint "--rewrite") -(fixpoint "--save") - -(constant sum (func(0, [int, int]))) - -(define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) }) - -(constraint - (forall ((x int) (x == 5)) - (( (sum x) = 15 )) - ) -) - diff --git a/tests/horn/pos/ple_sum_fuel.5.smt2 b/tests/horn/pos/ple_sum_fuel.5.smt2 deleted file mode 100644 --- a/tests/horn/pos/ple_sum_fuel.5.smt2 +++ /dev/null @@ -1,14 +0,0 @@ -(fixpoint "--rewrite") -(fixpoint "--save") -(fixpoint "--fuel=6") - -(constant sum (func(0, [int, int]))) - -(define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) }) - -(constraint - (forall ((x int) ((5 <= x) && (0 <= (sum (x-5))))) - ((15 <= (sum x))) - ) -) - diff --git a/tests/horn/pos/sum-rec-ok.smt2 b/tests/horn/pos/sum-rec-ok.smt2 deleted file mode 100644 --- a/tests/horn/pos/sum-rec-ok.smt2 +++ /dev/null @@ -1,24 +0,0 @@ -(qualif Bar ((v int)) (v >= 0)) - -(var $k_##1 ((Int))) - -(constraint - (and - (forall ((n int) (true)) - (forall ((cond bool) (cond <=> n <= 0)) - (and - (forall ((lq_tmp$grd##4 bool) (cond)) - (forall ((VV int) (VV == 0)) - (($k_##1 VV)))) - (forall ((lq_tmp$grd##4 bool) (not cond)) - (forall ((n1 int) (n1 == n - 1)) - (forall ((t1 int) ($k_##1 t1)) - (forall ((v int) (v == n + t1)) - (($k_##1 v))))))))) - (forall ((y int) (true)) - (forall ((r int) ($k_##1 r)) - (forall ((ok1 bool) (ok1 <=> 0 <= r)) - (forall ((v bool) (and (v <=> 0 <= r) (v == ok1))) - ((v)))))))) - - diff --git a/tests/horn/pos/sum-rec.smt2 b/tests/horn/pos/sum-rec.smt2 deleted file mode 100644 --- a/tests/horn/pos/sum-rec.smt2 +++ /dev/null @@ -1,24 +0,0 @@ -(qualif Bar ((v int)) (v >= 0)) - -(var $k_##1 ((int) (int))) - -(constraint - (and - (forall ((n int) (true)) - (forall ((cond bool) (cond <=> n <= 0)) - (and - (forall ((lq_tmp$grd##4 bool) (cond)) - (forall ((VV int) (VV == 0)) - (($k_##1 VV n)))) - (forall ((lq_tmp$grd##4 bool) (not cond)) - (forall ((n1 int) (n1 == n - 1)) - (forall ((t1 int) ($k_##1 t1 n1)) - (forall ((v int) (v == n + t1)) - (($k_##1 v n1))))))))) - (forall ((y int) (true)) - (forall ((r int) ($k_##1 r y)) - (forall ((ok1 bool) (ok1 <=> 0 <= r)) - (forall ((v bool) (and (v <=> 0 <= r) (v == ok1))) - ((v)))))))) - - diff --git a/tests/horn/pos/test00.smt2 b/tests/horn/pos/test00.smt2 deleted file mode 100644 --- a/tests/horn/pos/test00.smt2 +++ /dev/null @@ -1,15 +0,0 @@ -// TODO move to actual SMTLIB format -(fixpoint "--eliminate=horn") - -(qualif Foo ((v Int) (x Int)) (v = x)) -(qualif Bar ((v Int) (x Int)) (v > x)) - -(var $k1 ((Int) (Int) (Int))) -(var $k2 ((Int) (Int) (Int))) -(var $k3 ((Int) (Int) (Int))) - -(constraint - (forall ((x Int) (x > 0)) - (forall ((y Int) (y > x)) - (forall ((v Int) (v = x + y)) - ((v > 0)))))) diff --git a/tests/horn/pos/test01.smt2 b/tests/horn/pos/test01.smt2 deleted file mode 100644 --- a/tests/horn/pos/test01.smt2 +++ /dev/null @@ -1,12 +0,0 @@ -// TODO move to actual SMTLIB format -(fixpoint "--eliminate=horn") - -(constraint - (forall ((x Int) (x > 0)) - (and - (forall ((y Int) (y > x)) - (forall ((v Int) (v = x + y)) - ((v > 0)))) - (forall ((z Int) (z > 100)) - (forall ((v Int) (v = x + z)) - ((v > 100))))))) diff --git a/tests/horn/pos/test02.smt2 b/tests/horn/pos/test02.smt2 deleted file mode 100644 --- a/tests/horn/pos/test02.smt2 +++ /dev/null @@ -1,18 +0,0 @@ -// TODO move to actual SMTLIB format -(fixpoint "--eliminate=horn") - -(var $k0 ((Int))) - -(qualif Foo ((v Int)) ((v > 100))) - -(constraint - (forall ((x Int) (x > 0)) - (and - (forall ((y Int) (y > x + 100)) - (forall ((v Int) (v = x + y)) - (($k0 v)))) - (forall ((z Int) ($k0 z)) - (forall ((v Int) (v = x + z)) - ((v > 100))))))) - - diff --git a/tests/horn/pos/test03.smt2 b/tests/horn/pos/test03.smt2 deleted file mode 100644 --- a/tests/horn/pos/test03.smt2 +++ /dev/null @@ -1,22 +0,0 @@ -// TODO move to actual SMTLIB format - -(var $k0 ((Int))) - -(qualif Foo ((v Int)) ((v > 0))) - -(constraint - (and - (forall ((x Int) (x > 0)) - (forall ((v Int) (v = x)) - (($k0 v)))) - (forall ((y Int) ($k0 y)) - (forall ((v Int) (v = y + 1)) - (($k0 v)))) - (forall ((z Int) ($k0 z)) - ((z > 0))))) - - - - - - diff --git a/tests/minimize/two-cores.fq b/tests/minimize/two-cores.fq deleted file mode 100644 --- a/tests/minimize/two-cores.fq +++ /dev/null @@ -1,30 +0,0 @@ -qualif Cmp(v:a): (v = 10) -qualif Cmp(v:a): (v = 12) - -constraint: - env [] - lhs {v : int | [v = 10]} - rhs {v : int | [$k_0]} - id 1 tag [3] - -constraint: - env [] - lhs {v : int | [$k_0]} - rhs {v : int | [v != 10]} - id 4 tag [4] - -constraint: - env [] - lhs {v : int | [v = 12]} - rhs {v : int | [$k_0]} - id 2 tag [5] - -constraint: - env [] - lhs {v : int | [$k_0]} - rhs {v : int | [v != 12]} - id 3 tag [6] - -wf: - env [] - reft {v : int | [$k_0]} diff --git a/tests/neg/maps02.fq b/tests/neg/maps02.fq new file mode 100644 --- /dev/null +++ b/tests/neg/maps02.fq @@ -0,0 +1,9 @@ +bind 1 m1 : {v : Map_t Int Int | v = Map_default 0} +bind 2 s1 : {v : Set_Set Int | v = (Set_cup (Set_sng 10) (Set_sng 30))} +bind 3 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) } + +constraint: + env [ 1; 2; 3 ] + lhs {v : Set_Set Int | v = Map_to_set m2 } + rhs {v : Set_Set Int | v = s1 } + id 1 tag [] diff --git a/tests/pos/maps02.fq b/tests/pos/maps02.fq new file mode 100644 --- /dev/null +++ b/tests/pos/maps02.fq @@ -0,0 +1,16 @@ +bind 1 m1 : {v : Map_t Int Int | v = Map_default 0} +bind 2 s1 : {v : Set_Set Int | v = (Set_cup (Set_sng 10) (Set_sng 20))} +bind 3 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) } +bind 4 m3 : {v : Map_t Int Int | v = (Map_store (Map_store m1 20 1) 10 1) } + +constraint: + env [ 1; 2; 3 ] + lhs {v : Set_Set Int | v = Map_to_set m2 } + rhs {v : Set_Set Int | v = s1 } + id 1 tag [] + +constraint: + env [ 1; 2; 3; 4 ] + lhs {v : Set_Set Int | v = Map_to_set m3 } + rhs {v : Set_Set Int | v = s1 } + id 2 tag [] diff --git a/tests/pos/maps03.fq b/tests/pos/maps03.fq new file mode 100644 --- /dev/null +++ b/tests/pos/maps03.fq @@ -0,0 +1,10 @@ +bind 1 m1 : {v : Map_t Int Int | v = Map_default 0} +bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store (Map_store m1 30 3) 10 1) 20 2) } +bind 3 s1 : {v : Set_Set Int | v = (Set_cup (Set_sng 30) (Set_sng 20))} +bind 4 m3 : {v : Map_t Int Int | v = (Map_store (Map_store m1 20 2) 30 3) } + +constraint: + env [ 1; 2; 3; 4 ] + lhs {v : Map_t Int Int | v = Map_project s1 m2} + rhs {v : Map_t Int Int | v = m3 } + id 1 tag [] diff --git a/tests/pos/maps04.fq b/tests/pos/maps04.fq new file mode 100644 --- /dev/null +++ b/tests/pos/maps04.fq @@ -0,0 +1,39 @@ +bind 1 m1 : {v : Map_t Int Int | v = Map_default 0} +bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store (Map_store m1 30 3) 10 1) 20 2) } +bind 3 m3 : {v : Map_t Int Int | v = (Map_store (Map_store (Map_store m1 10 1) 20 1) 30 1) } + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_union_max m2 m3} + rhs {v : Map_t Int Int | v = m2 } + id 1 tag [] + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_union_max m1 m2} + rhs {v : Map_t Int Int | v = m2 } + id 2 tag [] + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_union_max m1 m3} + rhs {v : Map_t Int Int | v = m3 } + id 3 tag [] + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_union_min m2 m3} + rhs {v : Map_t Int Int | v = m3 } + id 4 tag [] + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_union_min m1 m2} + rhs {v : Map_t Int Int | v = m1 } + id 5 tag [] + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_union_min m1 m3} + rhs {v : Map_t Int Int | v = m1 } + id 6 tag [] diff --git a/tests/pos/maps05.fq b/tests/pos/maps05.fq new file mode 100644 --- /dev/null +++ b/tests/pos/maps05.fq @@ -0,0 +1,9 @@ +bind 1 m1 : {v : Map_t Int Int | v = Map_default 0} +bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store (Map_store m1 30 3) 10 1) 20 2) } +bind 3 m3 : {v : Map_t Int Int | v = (Map_store (Map_store (Map_store m1 130 3) 110 1) 120 2) } + +constraint: + env [ 1; 2; 3 ] + lhs {v : Map_t Int Int | v = Map_shift 100 m2} + rhs {v : Map_t Int Int | v = m3 } + id 1 tag [] diff --git a/tests/proof/GADTs.fq b/tests/proof/GADTs.fq deleted file mode 100644 --- a/tests/proof/GADTs.fq +++ /dev/null @@ -1,29 +0,0 @@ - -fixpoint "--rewrite" - -data Field 1 = [ - | FBool {} - | FInt {} - ] - -constant add : (func(0, [int; int; int])) -constant proj : (func(1, [Field @(0); @(0); @(0)])) - -define add (x:int, y:int): int = { - x + y -} -define proj (lq1 : (Field a), lq2 : a): a = { - if (is$FInt lq1) - then (coerce (int ~ a) (add (coerce (a ~ int) lq2) 1)) - else (coerce (bool ~ a) (not ((coerce (a ~ bool) lq2)))) -} - -match is$FInt FInt = (true) - -constraint: - env [] - lhs {v : int | true } - rhs {v : int | proj FInt 10 == 11 } - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/IndPal00.fq b/tests/proof/IndPal00.fq deleted file mode 100644 --- a/tests/proof/IndPal00.fq +++ /dev/null @@ -1,440 +0,0 @@ -fixpoint "--rewrite" - -data IndPalindrome.Pal 1 = [ - | IndPalindrome.Pals {PHead : @(0), PHeads : [@(0)]} - | IndPalindrome.Pal0 {} - ] -data IndPalindrome.PalP 1 = [ - | IndPalindrome.Pal {getPal : [@(0)]} - ] - - -match tail Cons lq_tmp$x##536 lq_tmp$x##537 = (lq_tmp$x##537) -match head Cons lq_tmp$x##536 lq_tmp$x##537 = (lq_tmp$x##536) -match isCons Cons lq_tmp$x##536 lq_tmp$x##537 = (true) -match isNil Cons lq_tmp$x##536 lq_tmp$x##537 = (false) -match len Cons lq_tmp$x##536 lq_tmp$x##537 = ((1 + (len lq_tmp$x##537))) -match isCons Nil = (false) -match isNil Nil = (true) -match len Nil = (0) -match getPal IndPalindrome.Pal lq_tmp$x##540x = (lq_tmp$x##540x) -match is$IndPalindrome.Pal IndPalindrome.Pal lq_tmp$x##540xx = (true) -// match IndPalindrome.Pal lq_tmp$x##540xxx = ((IndPalindrome.Pal lq_tmp$x##540xxx)) -match fromJust GHC.Maybe.Just lq_tmp$x##487 = (lq_tmp$x##487) -match is$IndPalindrome.Pals IndPalindrome.Pal0 = (false) -match is$IndPalindrome.Pal0 IndPalindrome.Pal0 = (true) -match prop IndPalindrome.Pal0 = ((IndPalindrome.Pal Nil)) -match PHeads IndPalindrome.Pals lq_tmp$x##495 lq_tmp$x##496 = (lq_tmp$x##496) -match PHead IndPalindrome.Pals lq_tmp$x##495 lq_tmp$x##496 = (lq_tmp$x##495) -match is$IndPalindrome.Pals IndPalindrome.Pals lq_tmp$x##495 lq_tmp$x##496 = (true) -match is$IndPalindrome.Pal0 IndPalindrome.Pals lq_tmp$x##495 lq_tmp$x##496 = (false) -match prop IndPalindrome.Pals lq_tmp$x##495 lq_tmp$x##496 = ((IndPalindrome.Pal lq_tmp$x##496)) -expand [23 : True] - - -bind 137 l : {VV##890 : [a##a2pJ] | [((len VV##890) > 0); ((isCons VV##890) <=> true); ((isNil VV##890) <=> false)]} -bind 138 d : {p : (IndPalindrome.Pal a##a2pJ) | [((prop p) = (IndPalindrome.Pal l)); - ((is$IndPalindrome.Pals p) <=> false); - ((is$IndPalindrome.Pal0 p) <=> true); - ((prop p) = (IndPalindrome.Pal Nil)); - (p = IndPalindrome.Pal0); - ((is$IndPalindrome.Pals p) <=> false); - ((is$IndPalindrome.Pal0 p) <=> true); - ((prop p) = (IndPalindrome.Pal Nil)); - (p = IndPalindrome.Pal0)]} -constraint: - env [137; - 138] - lhs {VV##F##23 : [Char] | [true ]} - rhs {VV##F##23 : [Char] | [IndPalindrome.Pal0 = d && isCons l && (l == Nil) && false]} - id 23 tag [4] - - -constant GHC.Base.id : (func(1 , [@(0); @(0)])) -constant GHC.List.init : (func(1 , [[@(0)]; [@(0)]])) -constant addrLen : (func(0 , [Str; int])) -constant papp5 : (func(10 , [(Pred @(0) @(1) @(2) @(3) @(4)); - @(5); - @(6); - @(7); - @(8); - @(9); - bool])) -constant GHC.List.iterate : (func(1 , [func(0 , [@(0); @(0)]); - @(0); - [@(0)]])) -constant x_Tuple21 : (func(2 , [(Tuple @(0) @(1)); @(0)])) -constant GHC.Classes.$61$$61$ : (func(1 , [@(0); @(0); bool])) -constant GHC.Types.C# : (func(0 , [Char; Char])) -constant GHC.List.drop : (func(1 , [int; [@(0)]; [@(0)]])) -constant getPal : (func(1 , [(IndPalindrome.PalP @(0)); - [@(0)]])) -constant isNil : (func(1 , [[@(0)]; bool])) -constant Data.Foldable.length : (func(2 , [(@(1) @(0)); int])) -constant x_Tuple33 : (func(3 , [(Tuple @(0) @(1) @(2)); @(2)])) -constant is$36$GHC.Tuple.$40$$44$$41$ : (func(2 , [(Tuple @(0) @(1)); - bool])) -constant GHC.Types.LT : (GHC.Types.Ordering) -constant lit$'Pal0 : (Str) -constant GHC.List.replicate : (func(1 , [int; @(0); [@(0)]])) -constant GHC.List.zipWith : (func(3 , [func(0 , [@(0); - @(1); - @(2)]); - [@(0)]; - [@(1)]; - [@(2)]])) -constant GHC.Classes.$62$$61$ : (func(1 , [@(0); @(0); bool])) -constant GHC.Types.$36$tc$91$$93$ : (GHC.Types.TyCon) -constant GHC.Num.fromInteger : (func(1 , [int; @(0)])) -constant papp3 : (func(6 , [(Pred @(0) @(1) @(2)); - @(3); - @(4); - @(5); - bool])) -constant GHC.List.span : (func(1 , [func(0 , [@(0); bool]); - [@(0)]; - (Tuple [@(0)] [@(0)])])) -constant lqdc$35$$35$$36$select$35$$35$GHC.Tuple.$40$$44$$44$$41$$35$$35$1 : (func(3 , [(Tuple @(0) @(1) @(2)); - @(0)])) -constant GHC.Classes.$62$ : (func(1 , [@(0); @(0); bool])) -constant GHC.Types.False : (bool) -constant GHC.List.scanr1 : (func(1 , [func(0 , [@(0); @(0); @(0)]); - [@(0)]; - [@(0)]])) -constant head : (func(1 , [[@(0)]; - @(0)])) -constant Cons : (func(1 , [@(0); [@(0)]; [@(0)]])) -constant GHC.List.scanl : (func(2 , [func(0 , [@(0); @(1); @(0)]); - @(0); - [@(1)]; - [@(0)]])) -constant lit$error : (Str) -constant is$IndPalindrome.Pal : (func(1 , [(IndPalindrome.PalP @(0)); - bool])) -constant GHC.Tuple.$40$$44$$44$$41$ : (func(3 , [@(0); - @(1); - @(2); - (Tuple @(0) @(1) @(2))])) -constant papp4 : (func(8 , [(Pred @(0) @(1) @(2) @(3)); - @(4); - @(5); - @(6); - @(7); - bool])) -constant GHC.Types.Module : (func(0 , [GHC.Types.TrName; - GHC.Types.TrName; - GHC.Types.Module])) -constant GHC.List.zip : (func(2 , [[@(0)]; - [@(1)]; - [(Tuple @(0) @(1))]])) -constant GHC.Tuple.$40$$41$ : (Tuple) -constant GHC.Types.I# : (func(0 , [int; int])) -constant GHC.Stack.Types.SrcLoc : (func(0 , [[Char]; - [Char]; - [Char]; - int; - int; - int; - int; - GHC.Stack.Types.SrcLoc])) -constant GHC.CString.unpackCString# : (func(0 , [Str; [Char]])) -constant GHC.Types.KindRepFun : (func(0 , [GHC.Types.KindRep; - GHC.Types.KindRep; - GHC.Types.KindRep])) -constant IndPalindrome.$fEqPalP : (func(1 , [(GHC.Classes.Eq (IndPalindrome.PalP @(0)))])) -constant lit$IndPalindrome : (Str) -constant IndPalindrome.Pals : (func(1 , [@(0); - [@(0)]; - (IndPalindrome.Pal @(0))])) -constant GHC.Types.KindRepTYPE : (func(0 , [GHC.Types.RuntimeRep; - GHC.Types.KindRep])) -constant GHC.List.dropWhile : (func(1 , [func(0 , [@(0); bool]); - [@(0)]; - [@(0)]])) -constant GHC.Real.C$58$Fractional : (func(1 , [func(0 , [@(0); - @(0); - @(0)]); - func(0 , [@(0); @(0)]); - func(0 , [(GHC.Real.Ratio int); @(0)]); - (GHC.Real.Fractional @(0))])) -constant autolen : (func(1 , [@(0); int])) -constant GHC.Integer.Type.$WJn# : (func(0 , [GHC.Integer.Type.BigNat; - int])) -constant GHC.Real.$94$ : (func(2 , [@(0); @(1); @(0)])) -constant head : (func(1 , [[@(0)]; @(0)])) -constant PHead : (func(1 , [(IndPalindrome.Pal @(0)); - @(0)])) -constant IndPalindrome.Pal : (func(1 , [[@(0)]; - (IndPalindrome.PalP @(0))])) -constant is$36$GHC.Tuple.$40$$44$$44$$41$ : (func(3 , [(Tuple @(0) @(1) @(2)); - bool])) -constant GHC.Types.$WKindRepTYPE : (func(0 , [GHC.Types.RuntimeRep; - GHC.Types.KindRep])) -constant GHC.Integer.Type.Jn# : (func(0 , [GHC.Prim.ByteArray#; - int])) -constant GHC.Classes.compare : (func(1 , [@(0); - @(0); - GHC.Types.Ordering])) -constant isCons : (func(1 , [[@(0)]; bool])) -constant papp2 : (func(4 , [(Pred @(0) @(1)); @(2); @(3); bool])) -constant GHC.Stack.Types.EmptyCallStack : (GHC.Stack.Types.CallStack) -constant GHC.Types.krep$36$$42$Arr$42$ : (GHC.Types.KindRep) -constant GHC.Stack.Types.emptyCallStack : (GHC.Stack.Types.CallStack) -constant GHC.List.reverse : (func(1 , [[@(0)]; [@(0)]])) -constant GHC.Integer.Type.$WJp# : (func(0 , [GHC.Integer.Type.BigNat; - int])) -constant lit$main : (Str) -constant GHC.List.filter : (func(1 , [func(0 , [@(0); bool]); - [@(0)]; - [@(0)]])) -constant fromJust : (func(1 , [(GHC.Maybe.Maybe @(0)); @(0)])) -constant GHC.Types.KindRepTyConApp : (func(0 , [GHC.Types.TyCon; - [GHC.Types.KindRep]; - GHC.Types.KindRep])) -constant GHC.List.cycle : (func(1 , [[@(0)]; [@(0)]])) -constant GHC.List.$33$$33$ : (func(1 , [[@(0)]; int; @(0)])) -constant GHC.List.tail : (func(1 , [[@(0)]; [@(0)]])) -constant lit$36$$47$Users$47$niki$47$liquidtypes$47$liquidhaskell$47$tests$47$ple$47$pos$47$IndPal00.hs : (Str) -constant papp7 : (func(14 , [(Pred @(0) @(1) @(2) @(3) @(4) @(5) @(6)); - @(7); - @(8); - @(9); - @(10); - @(11); - @(12); - @(13); - bool])) -constant GHC.Classes.$47$$61$ : (func(1 , [@(0); @(0); bool])) -constant GHC.List.break : (func(1 , [func(0 , [@(0); bool]); - [@(0)]; - (Tuple [@(0)] [@(0)])])) -constant GHC.Types.True : (bool) -constant Nil : (func(1 , [[@(0)]])) -constant GHC.List.splitAt : (func(1 , [int; - [@(0)]; - (Tuple [@(0)] [@(0)])])) -constant GHC.Base.$43$$43$ : (func(1 , [[@(0)]; [@(0)]; [@(0)]])) -constant GHC.Real.$58$$37$ : (func(1 , [@(0); - @(0); - (GHC.Real.Ratio @(0))])) -constant GHC.Tuple.$40$$44$$41$ : (func(2 , [@(0); - @(1); - (Tuple @(0) @(1))])) -constant GHC.Classes.$38$$38$ : (func(0 , [bool; bool; bool])) -constant lit$'Pals : (Str) -constant GHC.Types.GT : (GHC.Types.Ordering) -constant GHC.Classes.C$58$IP : (func(2 , [@(1); @(1)])) -constant GHC.Classes.$124$$124$ : (func(0 , [bool; bool; bool])) -constant GHC.Classes.$36$fEq$91$$93$ : (func(1 , [(GHC.Classes.Eq [@(0)])])) -constant Data.Either.Left : (func(2 , [@(0); - (Data.Either.Either @(0) @(1))])) -constant GHC.List.last : (func(1 , [[@(0)]; @(0)])) -constant GHC.Integer.Type.S# : (func(0 , [int; int])) -constant GHC.List.scanl1 : (func(1 , [func(0 , [@(0); @(0); @(0)]); - [@(0)]; - [@(0)]])) -constant Data.Either.Right : (func(2 , [@(1); - (Data.Either.Either @(0) @(1))])) -constant lit$'Pal : (Str) -constant GHC.Num.$45$ : (func(1 , [@(0); @(0); @(0)])) -constant len : (func(2 , [(@(0) @(1)); int])) -constant papp6 : (func(12 , [(Pred @(0) @(1) @(2) @(3) @(4) @(5)); - @(6); - @(7); - @(8); - @(9); - @(10); - @(11); - bool])) -constant GHC.Base.. : (func(3 , [func(0 , [@(0); @(1)]); - func(0 , [@(2); @(0)]); - @(2); - @(1)])) -constant x_Tuple22 : (func(2 , [(Tuple @(0) @(1)); @(1)])) -constant strLen : (func(0 , [[Char]; int])) -constant GHC.Types.KindRepTypeLitS : (func(0 , [GHC.Types.TypeLitSort; - Str; - GHC.Types.KindRep])) -constant GHC.Real.$36$W$58$$37$ : (func(1 , [@(0); - @(0); - (GHC.Real.Ratio @(0))])) -constant isJust : (func(1 , [(GHC.Maybe.Maybe @(0)); bool])) -constant GHC.List.takeWhile : (func(1 , [func(0 , [@(0); bool]); - [@(0)]; - [@(0)]])) -constant GHC.Types.TrNameD : (func(0 , [[Char]; GHC.Types.TrName])) -constant GHC.Types.KindRepVar : (func(0 , [int; - GHC.Types.KindRep])) -constant GHC.Stack.Types.pushCallStack : (func(0 , [(Tuple [Char] GHC.Stack.Types.SrcLoc); - GHC.Stack.Types.CallStack; - GHC.Stack.Types.CallStack])) -constant GHC.Types.KindRepTypeLitD : (func(0 , [GHC.Types.TypeLitSort; - [Char]; - GHC.Types.KindRep])) -constant x_Tuple31 : (func(3 , [(Tuple @(0) @(1) @(2)); @(0)])) -constant GHC.Integer.Type.Jp# : (func(0 , [GHC.Prim.ByteArray#; - int])) -constant GHC.IO.Exception.IOError : (func(0 , [(GHC.Maybe.Maybe GHC.IO.Handle.Types.Handle); - GHC.IO.Exception.IOErrorType; - [Char]; - [Char]; - (GHC.Maybe.Maybe GHC.Int.Int32); - (GHC.Maybe.Maybe [Char]); - GHC.IO.Exception.IOException])) -constant GHC.List.take : (func(1 , [int; [@(0)]; [@(0)]])) -constant GHC.Stack.Types.PushCallStack : (func(0 , [[Char]; - GHC.Stack.Types.SrcLoc; - GHC.Stack.Types.CallStack; - GHC.Stack.Types.CallStack])) -constant prop : (func(2 , [@(0); @(1)])) -constant GHC.Classes.$60$$61$ : (func(1 , [@(0); @(0); bool])) -constant GHC.Types.TrNameS : (func(0 , [Str; GHC.Types.TrName])) -constant is$IndPalindrome.Pal0 : (func(1 , [(IndPalindrome.Pal @(0)); - bool])) -constant GHC.Enum.C$58$Bounded : (func(1 , [@(0); - @(0); - (GHC.Enum.Bounded @(0))])) -constant GHC.Base.map : (func(2 , [func(0 , [@(0); @(1)]); - [@(0)]; - [@(1)]])) -constant lqdc$35$$35$$36$select$35$$35$GHC.Tuple.$40$$44$$41$$35$$35$2 : (func(2 , [(Tuple @(0) @(1)); - @(1)])) -constant GHC.Base.$ : (func(3 , [func(0 , [@(1); @(2)]); - @(1); - @(2)])) -constant papp1 : (func(2 , [(Pred @(0)); @(1); bool])) -constant GHC.Classes.max : (func(1 , [@(0); @(0); @(0)])) -constant lqdc$35$$35$$36$select$35$$35$GHC.Tuple.$40$$44$$44$$41$$35$$35$3 : (func(3 , [(Tuple @(0) @(1) @(2)); - @(2)])) -constant GHC.Classes.$60$ : (func(1 , [@(0); @(0); bool])) -constant tail : (func(1 , [[@(0)]; [@(0)]])) -constant lit$PalP : (Str) -constant lit$Pal : (Str) -constant GHC.Types.TyCon : (func(0 , [int; - int; - GHC.Types.Module; - GHC.Types.TrName; - int; - GHC.Types.KindRep; - GHC.Types.TyCon])) -constant GHC.Stack.Types.FreezeCallStack : (func(0 , [GHC.Stack.Types.CallStack; - GHC.Stack.Types.CallStack])) -constant GHC.Num.$42$ : (func(1 , [@(0); @(0); @(0)])) -constant GHC.Classes.$36$dm$47$$61$ : (func(1 , [@(0); - @(0); - bool])) -constant IndPalindrome.Pal0 : (func(1 , [(IndPalindrome.Pal @(0))])) -constant PHeads : (func(1 , [(IndPalindrome.Pal @(0)); - [@(0)]])) -constant GHC.Maybe.Nothing : (func(1 , [(GHC.Maybe.Maybe @(0))])) -constant GHC.Types.EQ : (GHC.Types.Ordering) -constant GHC.List.scanr : (func(2 , [func(0 , [@(0); @(1); @(1)]); - @(1); - [@(0)]; - [@(1)]])) -constant GHC.Num.negate : (func(1 , [@(0); @(0)])) -constant is$IndPalindrome.Pals : (func(1 , [(IndPalindrome.Pal @(0)); - bool])) -constant GHC.Real.fromIntegral : (func(2 , [@(0); @(1)])) -constant GHC.Maybe.Just : (func(1 , [@(0); - (GHC.Maybe.Maybe @(0))])) -constant GHC.Classes.min : (func(1 , [@(0); @(0); @(0)])) -constant GHC.List.head : (func(1 , [[@(0)]; @(0)])) -constant lqdc$35$$35$$36$select$35$$35$GHC.Tuple.$40$$44$$41$$35$$35$1 : (func(2 , [(Tuple @(0) @(1)); - @(0)])) -constant GHC.Types.$WKindRepVar : (func(0 , [int; - GHC.Types.KindRep])) -constant x_Tuple32 : (func(3 , [(Tuple @(0) @(1) @(2)); @(1)])) -constant GHC.Classes.C$58$Eq : (func(1 , [func(0 , [@(0); - @(0); - bool]); - func(0 , [@(0); @(0); bool]); - (GHC.Classes.Eq @(0))])) -constant GHC.List.repeat : (func(1 , [@(0); [@(0)]])) -constant tail : (func(1 , [[@(0)]; - [@(0)]])) -constant GHC.Classes.not : (func(0 , [bool; bool])) -constant GHC.Num.$43$ : (func(1 , [@(0); @(0); @(0)])) -constant Data.Tuple.fst : (func(2 , [(Tuple @(0) @(1)); @(0)])) -constant GHC.Types.KindRepApp : (func(0 , [GHC.Types.KindRep; - GHC.Types.KindRep; - GHC.Types.KindRep])) -constant GHC.Real.C$58$Integral : (func(1 , [func(0 , [@(0); - @(0); - @(0)]); - func(0 , [@(0); @(0); @(0)]); - func(0 , [@(0); @(0); @(0)]); - func(0 , [@(0); @(0); @(0)]); - func(0 , [@(0); @(0); (Tuple @(0) @(0))]); - func(0 , [@(0); @(0); (Tuple @(0) @(0))]); - func(0 , [@(0); int]); - (GHC.Real.Integral @(0))])) -constant GHC.Err.error : (func(2 , [[Char]; @(1)])) -constant snd : (func(2 , [(Tuple @(0) @(1)); @(1)])) -constant fst : (func(2 , [(Tuple @(0) @(1)); @(0)])) -constant lqdc$35$$35$$36$select$35$$35$GHC.Tuple.$40$$44$$44$$41$$35$$35$2 : (func(3 , [(Tuple @(0) @(1) @(2)); - @(1)])) -constant Data.Tuple.snd : (func(2 , [(Tuple @(0) @(1)); @(1)])) - - -distinct GHC.Types.LT : (GHC.Types.Ordering) -distinct lit$'Pal0 : (Str) -distinct GHC.Types.False : (bool) -distinct Cons : (func(1 , [@(0); [@(0)]; [@(0)]])) -distinct lit$error : (Str) -distinct GHC.Types.Module : (func(0 , [GHC.Types.TrName; - GHC.Types.TrName; - GHC.Types.Module])) -distinct GHC.Tuple.$40$$41$ : (Tuple) -distinct GHC.Types.I# : (func(0 , [int; int])) -distinct GHC.Stack.Types.SrcLoc : (func(0 , [[Char]; - [Char]; - [Char]; - int; - int; - int; - int; - GHC.Stack.Types.SrcLoc])) -distinct GHC.Types.KindRepFun : (func(0 , [GHC.Types.KindRep; - GHC.Types.KindRep; - GHC.Types.KindRep])) -distinct IndPalindrome.$fEqPalP : (func(1 , [(GHC.Classes.Eq (IndPalindrome.PalP @(0)))])) -distinct lit$IndPalindrome : (Str) -distinct IndPalindrome.Pals : (func(1 , [@(0); - [@(0)]; - (IndPalindrome.Pal @(0))])) -distinct IndPalindrome.Pal : (func(1 , [[@(0)]; - (IndPalindrome.PalP @(0))])) -distinct GHC.Stack.Types.EmptyCallStack : (GHC.Stack.Types.CallStack) -distinct lit$main : (Str) -distinct GHC.Types.KindRepTyConApp : (func(0 , [GHC.Types.TyCon; - [GHC.Types.KindRep]; - GHC.Types.KindRep])) -distinct lit$36$$47$Users$47$niki$47$liquidtypes$47$liquidhaskell$47$tests$47$ple$47$pos$47$IndPal00.hs : (Str) -distinct GHC.Types.True : (bool) -distinct Nil : (func(1 , [[@(0)]])) -distinct GHC.Tuple.$40$$44$$41$ : (func(2 , [@(0); - @(1); - (Tuple @(0) @(1))])) -distinct lit$'Pals : (Str) -distinct GHC.Types.GT : (GHC.Types.Ordering) -distinct lit$'Pal : (Str) -distinct GHC.Types.TrNameS : (func(0 , [Str; GHC.Types.TrName])) -distinct lit$PalP : (Str) -distinct lit$Pal : (Str) -distinct GHC.Types.TyCon : (func(0 , [int; - int; - GHC.Types.Module; - GHC.Types.TrName; - int; - GHC.Types.KindRep; - GHC.Types.TyCon])) -distinct IndPalindrome.Pal0 : (func(1 , [(IndPalindrome.Pal @(0))])) -distinct GHC.Types.EQ : (GHC.Types.Ordering) -distinct GHC.Classes.C$58$Eq : (func(1 , [func(0 , [@(0); - @(0); - bool]); - func(0 , [@(0); @(0); bool]); - (GHC.Classes.Eq @(0))])) - - diff --git a/tests/proof/IndPal000.fq b/tests/proof/IndPal000.fq deleted file mode 100644 --- a/tests/proof/IndPal000.fq +++ /dev/null @@ -1,23 +0,0 @@ -fixpoint "--rewrite" - - -match isCons Cons x xs = (true) -match isNil Cons x xs = (false) -match isCons Nil = (false) -match isNil Nil = (true) - -constant Cons : (func(1 , [@(0); [@(0)]; [@(0)]])) -constant isCons : (func(1 , [[@(0)]; bool])) -constant isNil : (func(1 , [[@(0)]; bool])) -constant Nil : (func(1 , [[@(0)]])) - -expand [1 : True] - -bind 1 l : {xs : [int] | true } -constraint: - env [1] - lhs {v:int | [isCons l && (l == Nil) ]} - rhs {v:int | [false]} - id 1 tag [] - - diff --git a/tests/proof/LH1424.fq b/tests/proof/LH1424.fq deleted file mode 100644 --- a/tests/proof/LH1424.fq +++ /dev/null @@ -1,42 +0,0 @@ -fixpoint "--rewrite" - -data Field 1 = [ - | FInt {} - ] - -define funky (ds : Field a, kkk : a) : int = {coerce (a ~ int) kkk } -constant funky : (func(1 , [(Field @(0)); @(0); int])) - -expand [1 : True; - 2 : True; - 3 : True - ] - -bind 1 tx : {VV : (Field bob) | []} -bind 2 ty : {VV : bob | []} -bind 3 fInt : {VV : Field int | [ VV = FInt]} - -constraint: - env [1; 2] - lhs {VV : int | [VV = (funky tx ty)]} - rhs {VV : int | [VV = (funky tx ty)]} - id 1 tag [] - -constraint: - env [3] - lhs {VV : int | []} - rhs {VV : int | [4 = (funky fInt 4)]} - id 2 tag [] - -constraint: - env [] - lhs {VV : int | []} - rhs {VV : int | [4 = (funky FInt 4)]} - id 3 tag [] - - - - - - - diff --git a/tests/proof/T387.fq b/tests/proof/T387.fq deleted file mode 100644 --- a/tests/proof/T387.fq +++ /dev/null @@ -1,27 +0,0 @@ -// minimized version of LH #1371 - -fixpoint "--rewrite" - -data Thing 0 = [ - | Op { left : Thing, right : Thing} - | N { eNum : int} - ] - -define killer (a1 : Thing, a2 : Thing) : Thing = { - if (is$N a1) - then (if (is$N a2) then (a1) else (Op (left a2) (killer (N (eNum a1)) (right a2)))) - else (Op (left a1) (killer (right a1) a2)) -} - -constant killer : (func(0 , [Thing; Thing; Thing])) - -bind 1 e2 : {v : Thing | true } -bind 2 tmp : {v : Thing | v = (killer (N 666) e2) } - -expand [1 : True] - -constraint: - env [1;2] - lhs {VV : Thing | [] } - rhs {VV : Thing | [1 + 2 = 3]} - id 1 tag [] diff --git a/tests/proof/T414.fq b/tests/proof/T414.fq deleted file mode 100644 --- a/tests/proof/T414.fq +++ /dev/null @@ -1,27 +0,0 @@ -fixpoint "--rewrite" -fixpoint "--etaelim" - -constant g : (func(0 , [int; int; int])) -constant f : (func(0 , [int; int; int])) -constant h : (func(0 , [int; int])) - -define f (x : int, y: int) : int = {g x y} - -define g (x : int, y: int) : int = {h y} - -bind 0 x : {x : int | []} -bind 1 y : {y : int | []} - -expand [1 : True; 2 : True ] - -constraint: - env [0;1] - lhs {v : int | true } - rhs {v : int | f = g } - id 2 tag [] - -constraint: - env [0;1] - lhs {v : int | true } - rhs {v : int | g x = h } - id 1 tag [] diff --git a/tests/proof/contra.fq b/tests/proof/contra.fq deleted file mode 100644 --- a/tests/proof/contra.fq +++ /dev/null @@ -1,22 +0,0 @@ -fixpoint "--rewrite" - -constant sem: (func(0, [int; int; (Set_Set int)])) - -define sem (i : int, j: int) : (Set_Set int) = { - if (i < j) then (Set_cup (Set_add (Set_empty 0) i) (sem (i + 1) j)) - else (Set_empty 0) -} - - -expand [1 : True] - -bind 1 i0 : { v : int | true } -bind 2 j0 : { v : int | true } -bind 3 p : { v : int | i0 < j0 } -bind 4 q : { v : int | j0 < i0 } - -constraint: - env [1; 2; 3; 4] - lhs {v : (Set_Set int) | v = sem i0 j0} - rhs {v : (Set_Set int) | v = sem j0 i0} - id 1 tag [] diff --git a/tests/proof/even.fq b/tests/proof/even.fq deleted file mode 100644 --- a/tests/proof/even.fq +++ /dev/null @@ -1,35 +0,0 @@ -fixpoint "--rewrite" - -data Peano 0 = [ - | Zero {} - | S {prev : Peano} - ] - -data BBool 0 = [ - | BTrue {} - | BFalse {} - ] - -constant negb : (func(0, [BBool; BBool])) -constant even : (func(0, [Peano; BBool])) - -define negb (x:BBool) : BBool = { - if (is$BTrue x) then BFalse else BTrue -} - -define even (x:Peano) : BBool = { - if (is$Zero x) then BTrue else - if (is$Zero (prev x)) then BFalse else - even (prev (prev x)) -} - - -bind 0 n : {v: Peano | not (is$Zero v) && is$S v && not (is$S (prev v)) && is$Zero (prev v) } - -constraint: - env [0] - lhs {v : bool | true } - rhs {v : bool | even (S n) == negb (even n) } - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/evenA.fq b/tests/proof/evenA.fq deleted file mode 100644 --- a/tests/proof/evenA.fq +++ /dev/null @@ -1,33 +0,0 @@ -fixpoint "--rewrite" - -data Peano 0 = [ - | Zero {} - | S {prev : Peano} - ] - -constant even : (func(0, [Peano; bool])) - - -define even (x:Peano) : bool = { - if (is$Zero x) then true else - ~ (even (prev n)) -} - - -match is$Zero Zero = (true) -match is$Zero S x = (false) -match is$S Zero = (false) -match is$S S x = (true) -match prev S x = (x) - -bind 0 n : {v: Peano | even v && is$S v && prev v == d } -bind 1 d : {v: Peano | true } -bind 2 z : {v: Peano | is$Zero v && v == d } - -constraint: - env [0; 1; 2] - lhs {v : bool | true } - rhs {v : bool | false } - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/intId.fq b/tests/proof/intId.fq deleted file mode 100644 --- a/tests/proof/intId.fq +++ /dev/null @@ -1,17 +0,0 @@ -fixpoint "--rewrite" - -constant intId: (func(0, [int; int])) - -define intId(x:int) : int = { - if (x == 0) then 0 else x - } - -expand [1 : True] - -bind 0 x : {v: int | true } - -constraint: - env [0] - lhs {v : int | true } - rhs {v : int | intId x = x } - id 1 tag [] diff --git a/tests/proof/list00.fq b/tests/proof/list00.fq deleted file mode 100644 --- a/tests/proof/list00.fq +++ /dev/null @@ -1,16 +0,0 @@ -fixpoint "--rewrite" - -constant len: (func(1, [(Main.List @(0)); int])) -constant Cons: (func(2, [@(0); (Main.List @(0)); (Main.List @(0))])) -constant Nil: (Main.List @(0)) - -match len Nil = 0 -match len Cons x xs = (1 + len xs) - -constraint: - env [] - lhs {v : int | true } - rhs {v : int | len (Cons 1 (Cons 2 (Cons 3 Nil))) = 3} - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/list01.fq b/tests/proof/list01.fq deleted file mode 100644 --- a/tests/proof/list01.fq +++ /dev/null @@ -1,26 +0,0 @@ -fixpoint "--rewrite" - -data Vec 1 = [ - | VNil { } - | VCons { head : @(0), tail : Vec @(0)} -] - -define filter (lq1 : func(0 , [a##a29r;bool]), lq2 : [a##a29r]) : [a##a29r] = { - if (isNil lq2) then Nil else ( - if (lq1 (head lq2)) - then (Cons (head lq2) (filter lq1 (tail lq2))) - else (filter lq1 (tail lq2))) -} - -constant len: (func(1, [(Vec @(0)); int])) - -match len VNil = 0 -match len VCons x xs = (1 + len xs) - -constraint: - env [] - lhs {v : int | true } - rhs {v : int | len (VCons 1 (VCons 2 (VCons 3 VNil))) = 3} - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/list01_adt.fq b/tests/proof/list01_adt.fq deleted file mode 100644 --- a/tests/proof/list01_adt.fq +++ /dev/null @@ -1,20 +0,0 @@ -fixpoint "--rewrite" - -data Vec 1 = [ - | VNil { } - | VCons { head : @(0), tail : Vec @(0)} -] - -constant len: (func(1, [(Vec @(0)); int])) - -define len(l: [a]) : int = { - if (is$VNil l) then 0 else (1 + len(tail l)) -} - -constraint: - env [] - lhs {v : int | true } - rhs {v : int | len (VCons 1 (VCons 2 (VCons 3 VNil))) = 3} - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/list02.fq b/tests/proof/list02.fq deleted file mode 100644 --- a/tests/proof/list02.fq +++ /dev/null @@ -1,29 +0,0 @@ -fixpoint "--rewrite" - -data Blob 0 = [ - | VBlob { vgoo : Int } - ] - -data Vec 1 = [ - | VCons { vhead : @(0) } -] - -constant len : (func(1, [(Vec @(0)); int])) -constant hen : (func(1, [Blob; int])) -constant tt : (Vec bool) -constant bob : (Blob) -constant foo : (func(0, [Blob; Blob])) - -match hen VBlob z = 10 - -match len VCons x = (hen (foo (VBlob 12))) - -bind 0 thing : {v: int | true} - -constraint: - env [0] - lhs {v : int | len (VCons 1) = 10 } - rhs {v : int | len (VCons 1) = 10 } - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/list03.fq b/tests/proof/list03.fq deleted file mode 100644 --- a/tests/proof/list03.fq +++ /dev/null @@ -1,52 +0,0 @@ -fixpoint "--rewrite" - -define ints2 (): [int] = { - Cons 1 (Cons 2 Nil) -} -define filter (lq1 : func(0 , [a##a29r;bool]), lq2 : [a##a29r]) : [a##a29r] = { - if (isNil lq2) then Nil else ( - if (lq1 (head lq2)) - then (Cons (head lq2) (filter lq1 (tail lq2))) - else (filter lq1 (tail lq2))) -} -define ints0 () : [int] = { - Cons 0 (Cons 1 (Cons 2 Nil)) -} -define isPos (lq1 : int) : bool = { - lq1 > 0 -} - - -match isCons Cons x xs = (true) -match isNil Cons x xs = (false) -match isCons Nil = (false) -match isNil Nil = (true) -match tail Cons x xs = (xs) -match head Cons x xs = (x) - -constant isCons : (func(1 , [[@(0)]; bool])) -constant isNil : (func(1 , [[@(0)]; bool])) -constant Nil : (func(1 , [[@(0)]])) -constant tail : (func(1 , [[@(0)];[@(0)]])) -constant head : (func(1 , [[@(0)];@(0)])) - - -constant ints0 : [int] -constant ints2 : [int] -constant filter : func(1 , [func(0 , [@(0); bool]);[@(0)];[@(0)]]) - -constant isPos : func(0 , [int; bool]) -constant Cons : func(1 , [@(0); - [@(0)]; - [@(0)]]) -constant Nil : func(1 , [[@(0)]]) - - - -constraint: - env [] - lhs {v : bool | true } - rhs {v : bool | filter isPos ints0 == ints2 } - id 1 tag [] - -expand [1 : True] diff --git a/tests/proof/ple0.fq b/tests/proof/ple0.fq deleted file mode 100644 --- a/tests/proof/ple0.fq +++ /dev/null @@ -1,13 +0,0 @@ -fixpoint "--rewrite" - -constant adder: (func(0, [int; int; int])) - -define adder(x : int, y : int) : int = { x + y } - -expand [1 : True] - -constraint: - env [] - lhs {v : int | true } - rhs {v : int | (adder 5 6) = 11 } - id 1 tag [] diff --git a/tests/proof/ple1.fq b/tests/proof/ple1.fq deleted file mode 100644 --- a/tests/proof/ple1.fq +++ /dev/null @@ -1,17 +0,0 @@ -fixpoint "--rewrite" - -constant foo: (func(1, [@(0) ; int])) -constant bar: (func(0, [Bob ; int])) - -define foo(x : alpha) : int = { bar (coerce (alpha ~ Bob) x) } -define bar(y : Bob) : int = { 22 } - -expand [1 : True] - -bind 0 z : {v: beta | true } - -constraint: - env [0] - lhs {v : int | true } - rhs {v : int | (foo z) = 22 } - id 1 tag [] diff --git a/tests/proof/ple2.fq b/tests/proof/ple2.fq deleted file mode 100644 --- a/tests/proof/ple2.fq +++ /dev/null @@ -1,19 +0,0 @@ -fixpoint "--rewrite" - -constant maker : (func(0, [int; QQ])) -constant QQ : (func(0, [int; QQ])) -constant selector : (func(0, [QQ; int])) - -match selector QQ x = (x) -define maker(n : int) : QQ = { QQ n } - -expand [1 : True] - -bind 0 z : {v: QQ | v = maker 10 } - -constraint: - env [0] - lhs {v : QQ | v = z } - rhs {v : QQ | selector v = 10 } - id 1 tag [] - diff --git a/tests/proof/ple3.fq b/tests/proof/ple3.fq deleted file mode 100644 --- a/tests/proof/ple3.fq +++ /dev/null @@ -1,40 +0,0 @@ -fixpoint "--rewrite" - - -data Blob 0 = [ - | VEmp { } - | VCons { blobKey : Int , blobVal : Int, blobTail : Blob} -] - -define set (s : Blob, key: Int, valu : Int) : Blob = { VCons key valu s } - -define get (s : Blob, key: Int) : Int = { - if (is$VEmp s) then - 0 - else if (key = (blobKey s)) then - (blobVal s) - else - (get (blobTail s) key) -} - -constant get : (func(0, [Blob; Int; Int])) -constant set : (func(0, [Blob; Int; Int; Blob])) - -expand [1 : True] -expand [2 : True] - -bind 0 s0 : {v: Blob | true } - -// UNSAT because we dont use the equality from v1 = set... when ple-ing (get v1 ...) -constraint: - env [0] - lhs {v1 : Blob | v1 = set s0 66 100 } - rhs {v1 : Blob | get v1 66 = 100 } - id 1 tag [] - -// SAT because the ple implementation first "normalizes" the arg to set -constraint: - env [0] - lhs {v2 : Blob | true } - rhs {v2 : Blob | get (set s0 66 100) 66 = 100 } - id 2 tag [] diff --git a/tests/proof/ple4.fq b/tests/proof/ple4.fq deleted file mode 100644 --- a/tests/proof/ple4.fq +++ /dev/null @@ -1,30 +0,0 @@ -// minimal reproduction of LH #1409. UNSAFE with --rewrite; SAFE with --rewrite --noincrple -fixpoint "--rewrite" - -data Peano 0 = [ - | S { prev : Peano} - | Z { } - ] - -expand [ 1 : True ] -expand [ 2 : True ] - -constant isEven : (func(0 , [Peano; int])) - -define isEven (n : Peano) : int = { if (is$Z n) then 1 else (1 - ((isEven (prev n)))) } - -bind 0 n : {n: Peano | (isEven n) = 1 } -bind 1 a : {a: Peano | n = S a } -bind 2 t2 : {v: int | a = Z } - -constraint: - env [0; 1] - lhs {v : int | true } - rhs {v : int | 1 + 2 = 3 } - id 1 tag [] - -constraint: - env [0; 1; 2] - lhs {v : int | true } - rhs {v : int | false } - id 2 tag [] diff --git a/tests/proof/pleBool.fq b/tests/proof/pleBool.fq deleted file mode 100644 --- a/tests/proof/pleBool.fq +++ /dev/null @@ -1,23 +0,0 @@ -fixpoint "--rewrite" - -constant geq: (func(0, [int; int; bool])) -constant lte: (func(0, [int; int; bool])) - -define geq(x:int, y:int) : bool = { - x >= y - } - -define lte(x:int, y:int) : bool = { - x <= y - } - -expand [1 : True] - -bind 0 x : {v: int | true } -bind 1 y : {v: int | true } - -constraint: - env [0; 1] - lhs {v : int | true } - rhs {v : int | geq x y <=> lte y x } - id 1 tag [] diff --git a/tests/proof/pleBoolA.fq b/tests/proof/pleBoolA.fq deleted file mode 100644 --- a/tests/proof/pleBoolA.fq +++ /dev/null @@ -1,50 +0,0 @@ -fixpoint "--rewrite" - -data Vec 1 = [ - | VNil { } - | VCons { head : @(0), tail : Vec @(0)} -] - -match isNil VNil = true -match isNil VCons x xs = false - -match isCons VNil = false -match isCons VCons x xs = true - - -constant mall: (func(0, [func(0,[int;bool]); Vec int; bool])) -constant geq: (func(0, [int; int; bool])) -constant mand: (func(0, [bool; bool; bool])) -constant lte: (func(0, [int; int; bool])) -constant isCons: (func(1, [Vec @(0); bool])) -constant isNil: (func(1, [Vec @(0); bool])) - - -define mall(f:func(0,[int;bool]), xs:Vec int) : bool = { - if (isNil xs) then true - else (mand (f (head xs)) (mall f (tail xs))) -} - -define mand(x:bool, y:bool) : bool = { - x && y - } - -define geq(x:int, y:int) : bool = { - x >= y - } - -define lte(x:int, y:int) : bool = { - x <= y - } - -expand [1 : True] - -bind 0 xs : {v: Vec int | true } -bind 1 x : {v: int | true } -bind 2 y : {v: int | true } - -constraint: - env [0; 1; 2] - lhs {v : int | true } - rhs {v : int | (mall (geq y) (VCons x xs)) = (mand (geq y x) (mall (geq y) xs)) } - id 1 tag [] diff --git a/tests/proof/pleBoolB.fq b/tests/proof/pleBoolB.fq deleted file mode 100644 --- a/tests/proof/pleBoolB.fq +++ /dev/null @@ -1,55 +0,0 @@ -fixpoint "--rewrite" - -data Vec 1 = [ - | VNil { } - | VCons { mhead : @(0), mtail : Vec @(0)} -] - -match isNil VNil = true -match isNil VCons x xs = false - -match isCons VNil = false -match isCons VCons x xs = true - - -match head VCons x xs = (x) -match tail VCons x xs = (xs) - -constant mall: (func(0, [func(0,[int;bool]); Vec int; bool])) -constant geq: (func(0, [int; int; bool])) -constant mand: (func(0, [bool; bool; bool])) -constant lte: (func(0, [int; int; bool])) -constant isCons: (func(1, [Vec @(0); bool])) -constant isNil: (func(1, [Vec @(0); bool])) -constant head: (func(1, [Vec @(0); @(0)])) -constant tail: (func(1, [Vec @(0); Vec @(0)])) - - -define mall(f:func(0,[int;bool]), xs:Vec int) : bool = { - if (isNil xs) then true - else (mand (f (head xs)) (mall f (tail xs))) -} - -define mand(x:bool, y:bool) : bool = { - if x then y else false - } - -define geq(x:int, y:int) : bool = { - x >= y - } - -define lte(x:int, y:int) : bool = { - x <= y - } - -expand [1 : True] - -bind 0 xs : {v: Vec int | true } -bind 1 x : {v: int | true } -bind 2 y : {v: int | true } - -constraint: - env [0; 1; 2] - lhs {v : int | true } - rhs {v : int | (mall (geq y) (VCons x xs)) = (mand (lte x y) (mall (geq y) xs)) } - id 1 tag [] diff --git a/tests/proof/pleBoolC.fq b/tests/proof/pleBoolC.fq deleted file mode 100644 --- a/tests/proof/pleBoolC.fq +++ /dev/null @@ -1,57 +0,0 @@ -fixpoint "--rewrite" - - -data Vec 1 = [ - | VNil { } - | VCons { mhead : @(0), mtail : Vec @(0) } -] - -match isNil VNil = true -match isNil VCons x xs = false - -match isCons VNil = false -match isCons VCons x xs = true - - -match head VCons x xs = (x) -match tail VCons x xs = (xs) - -constant mall: (func(0, [func(0,[int;bool]); Vec int; bool])) -constant geq: (func(0, [int; int; bool])) -constant mand: (func(0, [bool; bool; bool])) -constant lte: (func(0, [int; int; bool])) -constant isCons: (func(1, [Vec @(0); bool])) -constant isNil: (func(1, [Vec @(0); bool])) -constant head: (func(1, [Vec @(0); @(0)])) -constant tail: (func(1, [Vec @(0); Vec @(0)])) - - -define mall(f:func(0,[int;bool]), xs:Vec int) : bool = { - if (isNil xs) then true - else (mand (f (head xs)) (mall f (tail xs))) -} - -define mand(x:bool, y:bool) : bool = { - if x then y else false - } - -define geq(x:int, y:int) : bool = { - x >= y - } - -define lte(x:int, y:int) : bool = { - x <= y - } - -expand [1 : True] - -bind 0 xs : {v: Vec int | true } -bind 1 x : {v: int | true } -bind 2 y : {v: int | true } -bind 3 f : {v: (func(0,[int;bool])) | true } - -constraint: - env [0; 1; 2; 3] - lhs {v : bool | mand (lte x y) (mall (geq y) xs) } - rhs {v : bool | mall (geq y) (VCons x xs) } - id 1 tag [] diff --git a/tests/proof/pleSubst.fq b/tests/proof/pleSubst.fq deleted file mode 100644 --- a/tests/proof/pleSubst.fq +++ /dev/null @@ -1,18 +0,0 @@ -fixpoint "--rewrite" - -constant geq: (func(0, [int; int; bool])) -constant lte: (func(0, [int; int; bool])) - -define geq(x:int, y:int) : bool = { if x >= y then true else false } -define lte(x:int, y:int) : bool = { if x <= y then true else false } - -expand [1 : True] - -bind 0 x : {v: int | true } -bind 1 y : {v: int | true } - -constraint: - env [0; 1] - lhs {v : int | true } - rhs {v : int | geq x y <=> lte y x } - id 1 tag [] diff --git a/tests/proof/rewrite.fq b/tests/proof/rewrite.fq deleted file mode 100644 --- a/tests/proof/rewrite.fq +++ /dev/null @@ -1,61 +0,0 @@ -fixpoint "--rewrite" - -data List 0 = [ - | VNil { } - | VCons { head: Int, tail : List} -] - -define concat (left : List, right : List) : List = { - if (is$VNil left) then - right else - (VCons (head left) (concat (tail left) right)) -} - -define concat3Left (as : List, bs : List, cs : List) : List = { - concat (concat as bs) cs -} - -define concat3Right (as : List, bs : List, cs : List) : List = { - concat as (concat bs cs) -} - -autorewrite 1 {as : List | true} {bs : List | true} {cs : List | true} = { concat (concat as bs) cs = concat as (concat bs cs) } - -autorewrite 2 {as : List | true} {bs : List | true} {cs : List | true} = { concat as (concat bs cs) = concat (concat as bs) cs } - -constant concat : (func(0, [List;List;List])) -constant concat3Left : (func(0, [List; List; List; List])) -constant concat3Right : (func(0, [List; List; List; List])) - -expand [1 : True] -expand [2 : True] -expand [3 : True] - -rewrite [1 : 1] -rewrite [2 : 2] - -rewrite [3 : 1] -rewrite [3 : 2] - -bind 0 xs : {v: List | true } -bind 1 ys : {v: List | true } -bind 2 zs : {v: List | true } -bind 3 ws : {v: List | true } - -constraint: - env [0; 1; 2; 3] - lhs {v1 : List | true } - rhs {v2 : List | concat3Left (concat xs ws) ys zs = concat3Right (concat xs ws) ys zs } - id 1 tag [] - -constraint: - env [0; 1; 2; 3] - lhs {v1 : List | true } - rhs {v2 : List | concat3Right (concat xs ws) ys zs = concat3Left (concat xs ws) ys zs } - id 2 tag [] - -constraint: - env [0; 1; 2; 3] - lhs {v1 : List | true } - rhs {v2 : List | concat3Left (concat xs ws) ys zs = concat3Right xs ws (concat ys zs) } - id 3 tag [] diff --git a/tests/proof/sum.fq b/tests/proof/sum.fq deleted file mode 100644 --- a/tests/proof/sum.fq +++ /dev/null @@ -1,19 +0,0 @@ -fixpoint "--rewrite" - -constant sum : (func(0, [int; int])) - -define sum(n : int) : int = { if (n <= 0) then (0) else (n + sum (n-1)) } - - -expand [1 : True] -expand [2 : True] - -bind 0 n : {v : int | (3 <= v) } - -constraint: - env [] - lhs {v : int | true } - rhs {v : int | (sum 5) = 15 } - id 1 tag [] - - diff --git a/tests/rankNTypes/T407.hs.fq b/tests/rankNTypes/T407.hs.fq deleted file mode 100644 --- a/tests/rankNTypes/T407.hs.fq +++ /dev/null @@ -1,17 +0,0 @@ - -// test is an existential data type -// data Test a b = Test {forall z. z} -// @(2) is not bound by the two top variables - -data Test 2 = [ - | test { vtest : func(1 , [@(2)])} - ] - -bind 0 f : {v:int | true} -bind 1 g : {v:int | true} - -constraint: - env [0; 1] - lhs {v:int | test f = test g } - rhs {v:int | f = g } - id 1 tag [] diff --git a/tests/tasty/Arbitrary.hs b/tests/tasty/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/tasty/Arbitrary.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module Arbitrary + ( subexprs + , Env(..) + , NoAnfEnv(..) + , AnfSymbol(..) + , FlatAnfEnv(..) + , ChainedAnfEnv(..) + ) where + +import qualified Data.Text as Text +import qualified Data.HashMap.Strict as M +import Test.Tasty.QuickCheck +import GHC.Generics + +import Language.Fixpoint.Types.Refinements as R +import Language.Fixpoint.Parse (isNotReserved) +import Language.Fixpoint.Types as T hiding (Result) +import Language.Fixpoint.Types.Spans as Spans +import Data.Traversable (for) + +{- + +-- An example of how the Arbitrary Expr instance can be used. +-- Note that `expr == rr (showpp expr)` is *not* something we expect to hold. +-- See https://github.com/ucsd-progsys/liquid-fixpoint/issues/46 + +quickCheckTests :: TestTree +quickCheckTests + = testGroup "Properties" + [ testProperty "prop_pprint_parse_inv_expr" prop_pprint_parse_inv_expr + ] + +prop_pprint_parse_inv_expr :: Expr -> Bool +prop_pprint_parse_inv_expr expr = expr == rr (showpp expr) + +-} + +-- NOTE: `shrink _ = mempty` is identical to the default (implicit) shrink implementation. +-- We prefer to make it explicit. + +instance Arbitrary Expr where + arbitrary = sized arbitraryExpr + shrink x = filter valid $ genericShrink x + where + valid e@(T.PAnd es) = length es >= 2 && all valid (subexprs e) + valid e@(T.POr es) = length es >= 2 && all valid (subexprs e) + valid e@(T.PAll es _) = length es >= 2 && all valid (subexprs e) + valid e@(T.PExist es _) = length es >= 2 && all valid (subexprs e) + valid e = all valid (subexprs e) + +subexprs :: Expr -> [Expr] +subexprs (ESym _) = [] +subexprs (ECon _) = [] +subexprs (EVar _) = [] +subexprs (EApp e0 e1) = [e0, e1] +subexprs (ENeg e) = [e] +subexprs (EBin _ e0 e1) = [e0, e1] +subexprs (EIte e0 e1 e2) = [e0, e1, e2] +subexprs (ECst e _) = [e] +subexprs (ELam _ e) = [e] +subexprs (ETApp e _) = [e] +subexprs (ETAbs e _) = [e] +subexprs (T.PAnd es) = es +subexprs (T.POr es) = es +subexprs (T.PNot e) = [e] +subexprs (PImp e0 e1) = [e0, e1] +subexprs (PIff e0 e1) = [e0, e1] +subexprs (PAtom _ e0 e1) = [e0, e1] +subexprs (PKVar _ _) = [] +subexprs (PAll _ e) = [e] +subexprs (PExist _ e) = [e] +subexprs (PGrad _ _ _ e) = [e] +subexprs (ECoerc _ _ e) = [e] + +-- TODO: Adjust frequencies +-- | To ensure this reliably terminates we require that `zeroExprGen` generates +-- atomic expressions. +arbitraryFiniteExpr + :: Gen Expr -- ^ called when the Int is zero. + -> Int + -> Gen Expr +arbitraryFiniteExpr zeroExprGen 0 = zeroExprGen +arbitraryFiniteExpr zeroExprGen n = frequency + [ (1, EApp <$> arbitraryExpr' <*> arbitraryExpr') + , (1, ENeg <$> arbitraryExpr') + , (1, do + e <- EBin <$> arbitrary <*> arbitraryExpr' <*> arbitraryExpr' + return $ if divZero e then discard e else e) + , (1, EIte <$> arbitraryExpr' <*> arbitraryExpr' <*> arbitraryExpr') + , (1, ECst <$> arbitraryExpr' <*> arbitrary) + , (1, ELam <$> arbitrary <*> arbitraryExpr') + , (1, ETApp <$> arbitraryExpr' <*> arbitrary) + , (1, ETAbs <$> arbitraryExpr' <*> arbitrary) + , (1, T.PAnd <$> arbitraryExprList) + , (1, T.POr <$> arbitraryExprList) + , (1, T.PNot <$> arbitraryExpr') + , (1, PImp <$> arbitraryExpr' <*> arbitraryExpr') + , (1, PIff <$> arbitraryExpr' <*> arbitraryExpr') + , (1, PAtom <$> arbitrary <*> arbitraryExpr' <*> arbitraryExpr') + , (1, PKVar <$> arbitrary <*> arbitrary) + , (1, PAll <$> arbitraryList arbitrary <*> arbitraryExpr') + , (1, PExist <$> arbitraryList arbitrary <*> arbitraryExpr') + , (1, PGrad <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryExpr') + , (1, ECoerc <$> arbitrary <*> arbitrary <*> arbitraryExpr') + ] + where + arbitraryExpr' = arbitraryFiniteExpr zeroExprGen (n `div` 2) + arbitraryList :: Gen a -> Gen [a] + arbitraryList gen = choose (2, 3) >>= (`vectorOf` gen) + arbitraryExprList = arbitraryList arbitraryExpr' + + divZero :: Expr -> Bool + divZero (EBin Mod (ECon (I _)) (ECon (I 0))) = True + divZero (EBin Mod (ECon (R _)) (ECon (R 0.0))) = True + divZero (EBin Div (ECon (I _)) (ECon (I 0))) = True + divZero (EBin Div (ECon (R _)) (ECon (R 0.0))) = True + divZero _ = False + +-- | Generates a finite expression, with the logarithm of the Int given +-- suggesting the depth of the expression tree. +arbitraryExpr :: Int -> Gen Expr +arbitraryExpr = arbitraryFiniteExpr arbitraryAtomicExpr + +arbitraryAtomicExpr :: Gen Expr +arbitraryAtomicExpr = oneof [ESym <$> arbitrary, ECon <$> arbitrary, EVar <$> arbitrary] + +arbitraryEqualityConstraint :: Gen Brel +arbitraryEqualityConstraint = oneof [pure Eq, pure Ueq] + +-- | Generates an expression that involves the given Symbol in an Eq or Ueq +-- PAtom with an arbitrary non-lq_anf$ EVar. +arbitraryExprInvolving :: Symbol -> Int -> Gen Expr +arbitraryExprInvolving sym = arbitraryFiniteExpr . pure $ EVar sym + +instance Arbitrary KVar where + arbitrary = KV <$> arbitrary + +-- NOTE: This dummy Arbitrary instance returns a constant GradInfo. +instance Arbitrary GradInfo where + arbitrary = pure $ GradInfo (SS pos pos) Nothing + where pos = Spans.dummyPos "" + shrink _ = mempty + +instance Arbitrary Subst where + arbitrary = do + n <- choose (0, 3) + l <- vectorOf n arbitrary + return $ Su $ M.fromList l + shrink _ = mempty + +-- | This instance only creates `FVar` when they would be in scope from an +-- enclosing `FAbs`, and does not create `FObj`s +instance Arbitrary Sort where + arbitrary = sized arbitrarySort + shrink = genericShrink + +-- | Create an arbitrary well-formed sort that does not contain `FObj`s. +-- +-- The sort is \"well-formed\" in the sense that all `FVar`s have an enclosing +-- `FAbs` bringing them into scope. +arbitrarySort :: Int -> Gen Sort +arbitrarySort = arbitrarySortPossiblyInvolving [] + +-- | Create an arbitrary sort, possibly involving the variables represented by +-- the list of Ints. Can possibly create a `FAbs` that will also possibly +-- reference the new variable in an `FVar`, even when the first argument is +-- []. +arbitrarySortPossiblyInvolving :: [Int] -> Int -> Gen Sort +arbitrarySortPossiblyInvolving [] n = frequency + [ (4, arbitrarySortNoAbs n) + , (1, newAbs [] n) ] +arbitrarySortPossiblyInvolving vars n = do + let fvar = oneof $ pure . FVar <$> vars + frequency + [ (1, arbitrarySortNoAbs n) + , (1, FFunc <$> fvar <*> arbitrarySortPossiblyInvolving vars (n `div` 2)) + , (1, FFunc <$> arbitrarySortPossiblyInvolving vars (n `div` 2) <*> fvar) + , (1, FApp <$> fvar <*> arbitrarySortPossiblyInvolving vars (n `div` 2)) + , (1, FApp <$> arbitrarySortPossiblyInvolving vars (n `div` 2) <*> fvar) + , (1, fvar) + , (1, newAbs vars n) + ] + +-- | Create a new FAbs sort whose body might involve the newly created variable. +-- First argument is the variables already in scope. +newAbs :: [Int] -> Int -> Gen Sort +newAbs vars n = do + v <- arbitrary + if v `elem` vars + then discard v + else FAbs v <$> arbitrarySortPossiblyInvolving (v:vars) (n `div` 2) + +-- | Does not create FObj, FAbs, or FVar +arbitrarySortNoAbs :: Int -> Gen Sort +arbitrarySortNoAbs 0 = oneof (pure <$> [FInt, FReal, FNum, FFrac]) +arbitrarySortNoAbs n = frequency + [ (1, FFunc <$> arbitrarySortNoAbs' <*> arbitrarySortNoAbs') + , (1, FTC <$> arbitrary) + , (1, FApp <$> arbitrarySortNoAbs' <*> arbitrarySortNoAbs') + ] + where + arbitrarySortNoAbs' = arbitrarySortNoAbs (n `div` 2) + +instance Arbitrary Brel where + arbitrary = oneof (map return [Eq, Ne, Gt, Ge, Lt, Le, Ueq, Une]) + shrink _ = mempty + +instance Arbitrary Bop where + arbitrary = oneof (map return [Plus, Minus, Times, Div, Mod]) + shrink _ = mempty + +instance Arbitrary SymConst where + arbitrary = SL . unShortLowercaseAlphabeticText <$> arbitrary + +-- | Note that we rely below on the property that the Arbitrary instance for +-- Symbol cannot create lq_anf$ vars. +instance Arbitrary Symbol where + arbitrary = (symbol :: Text.Text -> Symbol) . unShortLowercaseAlphabeticText <$> arbitrary + shrink _ = mempty + +newtype ShortLowercaseAlphabeticText = ShortLowercaseAlphabeticText { unShortLowercaseAlphabeticText :: Text.Text } + deriving (Eq, Show, Generic) + +instance Arbitrary ShortLowercaseAlphabeticText where + arbitrary = ShortLowercaseAlphabeticText <$> (choose (5, 12) >>= \n -> Text.pack <$> (vectorOf n char `suchThat` valid)) + where + char = elements ['a'..'z'] + valid x = isNotReserved x && not (isFixKey (Text.pack x)) + shrink _ = mempty + +instance Arbitrary FTycon where + arbitrary = do + c <- elements ['A'..'Z'] + t <- unShortLowercaseAlphabeticText <$> arbitrary + return $ symbolFTycon $ dummyLoc $ symbol $ c `Text.cons` t + shrink _ = mempty + +instance Arbitrary Constant where + arbitrary = oneof [ I <$> arbitrary `suchThat` (>= 0) -- Negative values use `ENeg` + , R <$> arbitrary `suchThat` (>= 0) -- Negative values use `ENeg` + , L . unShortLowercaseAlphabeticText <$> arbitrary <*> arbitrary + ] + shrink (I x) = I <$> shrink x + shrink (R x) = R <$> shrink x + shrink (L x y) = L x <$> shrink y + +-- | Used in UndoANFTests. +newtype AnfSymbol = AnfSymbol { unAnfSymbol :: Symbol } + deriving (Eq, Show, Generic) +instance Arbitrary AnfSymbol where + arbitrary = AnfSymbol . mappendSym anfPrefix <$> arbitrary + shrink = mempty + +-- | This instance does **not** create Refts with anf symbols. +instance Arbitrary Reft where + arbitrary = reft <$> arbitrary <*> arbitrary + shrink = genericShrink + +-- | This instance does **not** create SortedRefts with anf symbols. +instance Arbitrary SortedReft where + arbitrary = sized $ arbitrarySortedReft (const arbitrary) (const arbitrary) + shrink = genericShrink + +arbitrarySortedReft :: (Int -> Gen Sort) -> (Int -> Gen Symbol) -> Int -> Gen SortedReft +arbitrarySortedReft sortGen symGen n = do + sort <- sortGen n + eq <- arbitraryEqualityConstraint + sym <- symGen n + RR sort . reft sym . PAtom eq (EVar sym) <$> arbitrary + +newtype IntSortedReft = IntSortedReft { unIntSortedReft :: SortedReft } + deriving (Eq, Show) + +instance Arbitrary IntSortedReft where + arbitrary = sized $ fmap IntSortedReft . arbitrarySortedReft (const . pure $ FInt) (const arbitrary) + +-- | Base environment with no declared properties; do not add an Arbitrary +-- instance to this and instead use newtypes. +newtype Env = Env { unEnv :: [(Symbol, SortedReft)] } + deriving (Eq, Show, Generic) + +shrinkEnv :: Env -> [Env] +shrinkEnv = fmap Env . traverse (traverse shrink) . unEnv + +-- | Env without anf vars. +newtype NoAnfEnv = NoAnfEnv { unNoAnfEnv :: Env } + deriving (Eq, Show, Generic) +instance Arbitrary NoAnfEnv where + arbitrary = sized (fmap NoAnfEnv . arbitraryEnv gen) + where + -- | Note that this relies on the property that the Arbitrary instance for + -- Symbol cannot create lq_anf$ vars. + gen n = vectorOf n ((\a b -> (a, unIntSortedReft b)) <$> arbitrary <*> arbitrary) + shrink = fmap NoAnfEnv . shrinkEnv . unNoAnfEnv + +-- | Env with anf vars that do not reference further anf vars. +newtype FlatAnfEnv = FlatAnfEnv { unFlatAnfEnv :: Env } + deriving (Eq, Show, Generic) +instance Arbitrary FlatAnfEnv where + arbitrary = sized (fmap FlatAnfEnv . arbitraryEnv gen) + where + anfsGen n = vectorOf n ((\a b -> (unAnfSymbol a, unIntSortedReft b)) <$> arbitrary <*> arbitrary) + gen = finalAnfGen anfsGen finalFlatGen + finalFlatGen :: [(Symbol, SortedReft)] -> Gen (Symbol, SortedReft) + -- This creates a final symbol which is either the conjunction or + -- disjunction of all the anf symbols. + finalFlatGen anfs = do + conjOrDisj <- oneof $ pure <$> [T.PAnd, T.POr] + let ultimateAnfExpr = conjOrDisj $ EVar . fst <$> anfs + sym <- arbitrary + ultimateAnfSym <- arbitrary + pure (sym, RR FInt (reft ultimateAnfSym (PAtom Eq (EVar ultimateAnfSym) ultimateAnfExpr))) + -- TODO + shrink (FlatAnfEnv (Env (_x : xs))) = pure . FlatAnfEnv . Env $ xs + shrink _ = mempty + +-- | Given a generator for a bunch of (`Symbol`, `SortedReft`) pairs which bind +-- lq_anf$ vars, and another generator that takes those pairs and binds a +-- non-lq_anf$ var to some subset of them, this function generates those pairs +-- plus the \"final\" non-lq_anf$ expression, which represents the \"original\" +-- expression brought to ANF. +finalAnfGen :: (Int -> Gen [(Symbol, SortedReft)]) -> ([(Symbol, SortedReft)] -> Gen (Symbol, SortedReft)) -> Int -> Gen [(Symbol, SortedReft)] +finalAnfGen anfsGen finalGen n = do + anfs <- anfsGen n + ultimateAnf <- finalGen anfs + pure $ ultimateAnf : anfs + +-- | Create an arbitrary env up to size k with the given generator for Symbols +-- and SortedRefts +arbitraryEnv :: (Int -> Gen [(Symbol, SortedReft)]) -> Int -> Gen Env + +arbitraryEnv gen k = Env <$> (choose (0, k) >>= gen) + +-- | Env with anf vars that form a list of references. +newtype ChainedAnfEnv = ChainedAnfEnv { unChainedAnfEnv :: Env } + deriving (Eq, Show, Generic) +instance Arbitrary ChainedAnfEnv where + arbitrary = sized (fmap ChainedAnfEnv . arbitraryEnv gen) + where + gen = finalAnfGen (chainedAnfGen anfSymNGen) finalChainedGen + finalChainedGen :: [(Symbol, SortedReft)] -> Gen (Symbol, SortedReft) + finalChainedGen anfs = + case anfs of + -- No ANFs, so just an arbitrary int sorted expression will do + [] -> fmap unIntSortedReft <$> arbitrary + ((penultimateSym, _):_) -> do + sym <- arbitrary + let sreft = RR FInt (reft sym (PAtom Eq (EVar sym) (EVar penultimateSym))) + (, sreft) <$> arbitrary + -- TODO + shrink (ChainedAnfEnv (Env (_x : xs))) = pure . ChainedAnfEnv . Env $ xs + shrink _ = mempty + +-- | Creates a "chain" of referencing `lq_anf$` var Symbols of length `n` such +-- that the first symbol references the second which references the third, and +-- so on. The last symbol is bound to an arbitrary non-lq_anf$ var. +-- +-- This list is in an acceptable form to be passed to `finalAnfGen` to close the +-- loop. +chainedAnfGen :: (Int -> Gen AnfSymbol) -> Int -> Gen [(Symbol, SortedReft)] +chainedAnfGen _ 0 = pure [] +chainedAnfGen symGen n = do + syms <- fmap unAnfSymbol <$> for [1..n+1] symGen + finalSym <- arbitrary + let symPairs :: [(Symbol, Symbol)] + symPairs = pairs (syms ++ [finalSym]) + for symPairs $ \(sym, prevSym) -> do + otherSym <- arbitrary + prevSymExpr <- arbitraryExprInvolving prevSym n + pure (sym, RR FInt (reft otherSym (PAtom Eq (EVar otherSym) prevSymExpr))) + where + pairs xs = zip xs (tail xs) + +-- This is not random, but is simplified so that you can make chains more +-- easily. +anfSymNGen :: Int -> Gen AnfSymbol +anfSymNGen i = pure . AnfSymbol . mappendSym anfPrefix . symbol . show $ i diff --git a/tests/tasty/InterpretTests.hs b/tests/tasty/InterpretTests.hs new file mode 100644 --- /dev/null +++ b/tests/tasty/InterpretTests.hs @@ -0,0 +1,30 @@ +module InterpretTests (tests) where + +import Arbitrary () +import Language.Fixpoint.Types.Refinements (Expr (..)) +import qualified SimplifyInterpreter +import Test.Tasty + ( TestTree, + localOption, + testGroup, + ) +import Test.Tasty.QuickCheck + ( Property, + QuickCheckMaxSize (..), + QuickCheckTests (..), + testProperty, + (===), + ) + +tests :: TestTree +tests = + withOptions $ + testGroup + "interpret" + [ testProperty "computes a fixpoint" (prop_fixpoint SimplifyInterpreter.interpret') + ] + where + withOptions tests' = localOption (QuickCheckMaxSize 4) (localOption (QuickCheckTests 500) tests') + +prop_fixpoint :: (Expr -> Expr) -> Expr -> Property +prop_fixpoint f e = f e === f (f e) diff --git a/tests/tasty/Main.hs b/tests/tasty/Main.hs --- a/tests/tasty/Main.hs +++ b/tests/tasty/Main.hs @@ -4,11 +4,16 @@ import qualified ParserTests import qualified ShareMapTests +import qualified SimplifyTests +import qualified InterpretTests +import qualified UndoANFTests import Test.Tasty -import Test.Tasty.HUnit main :: IO () main = defaultMain $ testGroup "Tests" [ ParserTests.tests , ShareMapTests.tests + , SimplifyTests.tests + , InterpretTests.tests + , UndoANFTests.tests ] diff --git a/tests/tasty/ShareMapReference.hs b/tests/tasty/ShareMapReference.hs --- a/tests/tasty/ShareMapReference.hs +++ b/tests/tasty/ShareMapReference.hs @@ -71,8 +71,7 @@ | otherwise -> let v0 = h HashMap.! k0 v1 = maybe v0 (f v0) $ HashMap.lookup k1 h - keys' - | otherwise = case break (HashSet.member k1) (before0 ++ after0) of + keys' = case break (HashSet.member k1) (before0 ++ after0) of (before1, []) -> HashSet.insert k1 keys0 : before1 (before1, keys1 : after1)-> diff --git a/tests/tasty/ShareMapTests.hs b/tests/tasty/ShareMapTests.hs --- a/tests/tasty/ShareMapTests.hs +++ b/tests/tasty/ShareMapTests.hs @@ -3,13 +3,11 @@ module ShareMapTests where import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap import Data.List (foldl', nub) import qualified Data.ShareMap as ShareMap import qualified ShareMapReference as Reference import Test.Tasty import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -- | Compare Data.ShareMap against a reference implementation tests :: TestTree diff --git a/tests/tasty/SimplifyInterpreter.hs b/tests/tasty/SimplifyInterpreter.hs new file mode 100644 --- /dev/null +++ b/tests/tasty/SimplifyInterpreter.hs @@ -0,0 +1,40 @@ +module SimplifyInterpreter (interpret', simplify') where + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Language.Fixpoint.Solver.Interpreter (ICtx (..), Knowledge (..)) +import qualified Language.Fixpoint.Solver.Interpreter as Interpreter +import Language.Fixpoint.Types.Environments (SEnv (..)) +import Language.Fixpoint.Types.Refinements (Expr) + +interpret' :: Expr -> Expr +interpret' = Interpreter.interpret emptyConstMap emptyKnowledge emptyICtx emptySEnv + where + emptyConstMap = M.empty + emptySEnv = SE M.empty + +simplify' :: Expr -> Expr +simplify' = Interpreter.simplify emptyKnowledge emptyICtx + +emptyKnowledge :: Interpreter.Knowledge +emptyKnowledge = + Interpreter.KN + { knSims = M.empty, -- :: M.HashMap (Symbol, Symbol) Rewrite + knAms = M.empty, -- :: M.HashMap Symbol Equation + knLams = [], -- :: ![(Symbol, Sort)] + knSummary = [], -- :: ![(Symbol, Int)] + knDCs = S.empty, -- :: !(S.HashSet Symbol) + knAllDCs = S.empty, -- :: !(S.HashSet Symbol) + knSels = M.empty, -- :: !SelectorMap + knConsts = M.empty -- :: !ConstDCMap + } + +emptyICtx :: Interpreter.ICtx +emptyICtx = + Interpreter.ICtx + { icCands = S.empty, -- :: S.HashSet Expr + icEquals = S.empty, -- :: EvAccum + icSolved = S.empty, -- :: S.HashSet Expr + icSimpl = M.empty, -- :: !ConstMap + icSubcId = Nothing -- :: Maybe SubcId + } diff --git a/tests/tasty/SimplifyPLE.hs b/tests/tasty/SimplifyPLE.hs new file mode 100644 --- /dev/null +++ b/tests/tasty/SimplifyPLE.hs @@ -0,0 +1,41 @@ +module SimplifyPLE (simplify') where + +import qualified Data.HashMap.Strict as SM +import qualified Data.HashSet as S +import qualified Data.Map as M +import Language.Fixpoint.Solver.PLE (ICtx (..), Knowledge (..)) +import qualified Language.Fixpoint.Solver.PLE as PLE +import Language.Fixpoint.Types.Refinements (Expr) + +simplify' :: Expr -> Expr +simplify' = PLE.simplify emptyKnowledge emptyICtx + where + emptyKnowledge :: PLE.Knowledge + emptyKnowledge = + -- @PLE.simplify@ does not actually use all these fields, so we can get + -- away with leaving some of them @undefined@. + KN + { knSims = M.empty, -- :: Map Symbol [(Rewrite, IsUserDataSMeasure)] + knAms = M.empty, -- :: Map Symbol Equation + knContext = undefined, -- :: SMT.Context + knPreds = undefined, -- :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool + knLams = [], -- :: ![(Symbol, Sort)] + knSummary = [], -- :: ![(Symbol, Int)] + knDCs = S.empty, -- :: !(S.HashSet Symbol) + knDataCtors = SM.empty, -- :: !(M.HashMap Symbol DataCtor) + knSels = [], -- :: !SelectorMap + knConsts = [], -- :: !ConstDCMap + knAutoRWs = SM.empty, -- :: M.HashMap SubcId [AutoRewrite] + knRWTerminationOpts = undefined -- :: RWTerminationOpts + } + + emptyICtx :: PLE.ICtx + emptyICtx = + ICtx + { icAssms = S.empty, -- S.HashSet Pred + icCands = S.empty, -- :: S.HashSet Expr + icEquals = S.empty, -- :: EvAccum + icSimpl = SM.empty, -- :: !ConstMap + icSubcId = Nothing, -- :: Maybe SubcId + icANFs = [] -- :: [[(Symbol, SortedReft)]] + } diff --git a/tests/tasty/SimplifyTests.hs b/tests/tasty/SimplifyTests.hs new file mode 100644 --- /dev/null +++ b/tests/tasty/SimplifyTests.hs @@ -0,0 +1,49 @@ +module SimplifyTests (tests) where + +import Arbitrary (subexprs) +import Language.Fixpoint.Types.Refinements (Bop (Minus), Constant (I), Expr (..)) +import qualified SimplifyInterpreter +import qualified SimplifyPLE +import Test.Tasty + ( TestTree, + localOption, + testGroup, + ) +import Test.Tasty.QuickCheck + ( Property, + QuickCheckMaxSize (..), + QuickCheckTests (..), + counterexample, + label, + testProperty, + ) + +tests :: TestTree +tests = + withOptions $ + testGroup + "simplify does not increase expression size" + [ testProperty "PLE" (prop_no_increase SimplifyPLE.simplify'), + testProperty "Interpreter" (prop_no_increase SimplifyInterpreter.simplify') + ] + where + withOptions tests' = localOption (QuickCheckMaxSize 4) (localOption (QuickCheckTests 500) tests') + +prop_no_increase :: (Expr -> Expr) -> Expr -> Property +prop_no_increase f e = + let originalSize = exprSize e + simplified = f e + simplifiedSize = exprSize simplified + in label ("reduced size by " ++ show (originalSize - simplifiedSize)) $ + counterexample + ( unlines + [ show simplifiedSize ++ " > " ++ show originalSize, + "simplified: " ++ show simplified + ] + ) + (simplifiedSize <= originalSize) + +exprSize :: Expr -> Int +-- Undo the removal of ENeg in @simplify@ so it does not count as increasing the size of the expression. +exprSize (EBin Minus (ECon (I 0)) e) = exprSize (ENeg e) +exprSize e = 1 + sum (exprSize <$> subexprs e) diff --git a/tests/tasty/UndoANFTests.hs b/tests/tasty/UndoANFTests.hs new file mode 100644 --- /dev/null +++ b/tests/tasty/UndoANFTests.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +module UndoANFTests(tests) where + +import Language.Fixpoint.Types (SortedReft(..), Symbol, + isPrefixOfSym, anfPrefix, syms) +import Language.Fixpoint.Solver.EnvironmentReduction (undoANFSimplifyingWith) +import Arbitrary +import qualified Data.HashMap.Strict as M +import Test.Tasty (TestTree, testGroup, adjustOption) +import Test.Tasty.HUnit ((@?=)) +import qualified Test.Tasty.HUnit as H +import Test.Tasty.QuickCheck ((===)) +import qualified Test.Tasty.QuickCheck as Q + + +tests :: TestTree +tests = + withOptions $ + testGroup + "undoANFSimplifyingWith id id" + [ H.testCase "id on empty env" $ + simpleUndoANF [] @?= M.empty + , Q.testProperty "id when env contains no lq_anf$* bindings" $ + prop_no_change (M.fromList . unEnv . unNoAnfEnv) simpleUndoANFNoAnfEnv + , testGroup + "zero anf vars left afterwards, starting with:" + [ Q.testProperty "no anf vars" $ + prop_no_anfs simpleUndoANFNoAnfEnv + , Q.testProperty "single-level anf vars" $ + prop_no_anfs simpleUndoANFFlatAnfEnv + , Q.testProperty "chained anf vars" $ + prop_no_anfs simpleUndoANFChainedAnfEnv + ] + ] + where + withOptions = adjustOption (min (Q.QuickCheckMaxSize 8)) -- adjustOption . min because we don't want to default to the enormous value. + . adjustOption (max (Q.QuickCheckTests 500)) -- adjustOption . max because we may want larger on the command line. + +-- | 5 seconds (in microseconds). +timeout :: Int +timeout = 5000000 + +prop_no_change :: (Q.Arbitrary e, Eq e, Show e) => (e -> M.HashMap Symbol SortedReft) -> (e -> M.HashMap Symbol SortedReft) -> e -> Q.Property +prop_no_change toHashMap f e = Q.within timeout $ f e === toHashMap e + +prop_no_anfs :: (Q.Arbitrary e, Eq e, Show e) => (e -> M.HashMap Symbol SortedReft) -> e -> Q.Property +prop_no_anfs f e = Q.within timeout . checkNoAnfs . f $ e + where + checkNoAnfs m = M.filter (any isAnfVar . syms) m === M.empty + isAnfVar = isPrefixOfSym anfPrefix + +-- | We perform tests with only trivial lenses (i.e. id) +simpleUndoANF :: [(Symbol, SortedReft)] -> M.HashMap Symbol SortedReft +simpleUndoANF = undoANFSimplifyingWith id id . M.fromList + +---------------------------------------------------- +-- | simpleUndoANF conjugated with various newtypes +---------------------------------------------------- + +simpleUndoANFEnv :: Env -> M.HashMap Symbol SortedReft +simpleUndoANFEnv = simpleUndoANF . unEnv + +simpleUndoANFNoAnfEnv :: NoAnfEnv -> M.HashMap Symbol SortedReft +simpleUndoANFNoAnfEnv = simpleUndoANFEnv . unNoAnfEnv + +simpleUndoANFFlatAnfEnv :: FlatAnfEnv -> M.HashMap Symbol SortedReft +simpleUndoANFFlatAnfEnv = simpleUndoANFEnv . unFlatAnfEnv + +simpleUndoANFChainedAnfEnv :: ChainedAnfEnv -> M.HashMap Symbol SortedReft +simpleUndoANFChainedAnfEnv = simpleUndoANFEnv . unChainedAnfEnv diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,24 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Main where import qualified Control.Concurrent.STM as STM import qualified Data.Functor.Compose as Functor import qualified Data.IntMap as IntMap -import qualified Data.Map as Map import qualified Control.Monad.State as State import Control.Monad.Trans.Class (lift) -import Data.Char +import Prelude hiding (log) import Data.Maybe (fromMaybe) -import Data.Monoid (Sum(..), (<>)) +import Data.Monoid (Sum(..)) +import Data.Proxy +import Data.Tagged import Control.Applicative +import Options.Applicative import System.Directory import System.Exit import System.FilePath -import System.Environment import System.IO import System.IO.Error import System.Process @@ -30,17 +31,14 @@ import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.Runners.AntXML -import Paths_liquid_fixpoint main :: IO () -main = do +main = do run =<< group "Tests" [unitTests] where - run = defaultMainWithIngredients [ - testRunner - -- , includingOptions [ Option (Proxy :: Proxy NumThreads) - -- , Option (Proxy :: Proxy LiquidOpts) - -- , Option (Proxy :: Proxy SmtSolver) ] + run = defaultMainWithIngredients + [ testRunner + , includingOptions [ Option (Proxy :: Proxy FixpointOpts) ] ] testRunner :: Ingredient @@ -65,6 +63,7 @@ return $ \smap -> f1 smap >> f2 smap combineReporters _ _ = error "combineReporters needs TestReporters" +unitTests :: IO TestTree unitTests = group "Unit" [ testGroup "native-pos" <$> dirTests nativeCmd "tests/pos" skipNativePos ExitSuccess @@ -89,10 +88,32 @@ skipNativePos :: [FilePath] skipNativePos = ["NonLinear-pack.fq"] +newtype FixpointOpts = LO String deriving (Show, Read, Eq, Ord) + +instance Semigroup FixpointOpts where + (LO "") <> y = y + x <> (LO "") = x + (LO x) <> (LO y) = LO $ x ++ (' ' : y) + +instance Monoid FixpointOpts where + mempty = LO "" + mappend = (<>) + +instance IsOption FixpointOpts where + defaultValue = LO "" + parseValue = Just . LO + optionName = return "fixpoint-opts" + optionHelp = return "Extra options to pass to fixpoint" + optionCLParser = + option (fmap LO str) + ( long (untag (optionName :: Tagged FixpointOpts String)) + <> help (untag (optionHelp :: Tagged FixpointOpts String)) + ) + --------------------------------------------------------------------------- dirTests :: TestCmd -> FilePath -> [FilePath] -> ExitCode -> IO [TestTree] --------------------------------------------------------------------------- -dirTests testCmd root ignored code = do +dirTests testCmd root ignored code = do files <- walkDirectory root let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ] return $ mkTest testCmd code root <$> tests @@ -104,7 +125,9 @@ mkTest :: TestCmd -> ExitCode -> FilePath -> FilePath -> TestTree --------------------------------------------------------------------------- mkTest testCmd code dir file - = testCase file $ + = + askOption $ \opts -> + testCase file $ if test `elem` knownToFail then do printf "%s is known to fail: SKIPPING" test @@ -112,7 +135,7 @@ else do createDirectoryIfMissing True $ takeDirectory log withFile log WriteMode $ \h -> do - let cmd = testCmd "fixpoint" dir file + let cmd = testCmd opts "fixpoint" dir file (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h} c <- waitForProcess ph assertEqual "Wrong exit code" code c @@ -120,162 +143,24 @@ test = dir file log = let (d,f) = splitFileName file in dir d ".liquid" f <.> "log" +knownToFail :: [a] knownToFail = [] --------------------------------------------------------------------------- -type TestCmd = FilePath -> FilePath -> FilePath -> String +type TestCmd = FixpointOpts -> FilePath -> FilePath -> FilePath -> String nativeCmd :: TestCmd -nativeCmd bin dir file = printf "cd %s && %s %s" dir bin file +nativeCmd (LO opts) bin dir file = + printf "cd %s && %s %s %s" dir bin opts file elimCmd :: TestCmd -elimCmd bin dir file = printf "cd %s && %s --eliminate=some %s" dir bin file - - - - - - - - - - - - - - - ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- - -{- - -quickCheckTests :: TestTree -quickCheckTests - = testGroup "Properties" - [ testProperty "prop_pprint_parse_inv_expr" prop_pprint_parse_inv_expr - , testProperty "prop_pprint_parse_inv_pred" prop_pprint_parse_inv_pred - ] - -prop_pprint_parse_inv_pred :: Pred -> Bool -prop_pprint_parse_inv_pred p = p == rr (showpp p) - -prop_pprint_parse_inv_expr :: Expr -> Bool -prop_pprint_parse_inv_expr p = simplify p == rr (showpp $ simplify p) - -instance Arbitrary Sort where - arbitrary = sized arbSort - -arbSort 0 = oneof [return FInt, return FReal, return FNum] -arbSort n = frequency - [(1, return FInt) - ,(1, return FReal) - ,(1, return FNum) - ,(2, fmap FObj arbitrary) - ] - - -instance Arbitrary Pred where - arbitrary = sized arbPred - shrink = filter valid . genericShrink - where - valid (PAnd []) = False - valid (PAnd [_]) = False - valid (POr []) = False - valid (POr [_]) = False - valid (PBexp (EBin _ _ _)) = True - valid (PBexp _) = False - valid _ = True - -arbPred 0 = elements [PTrue, PFalse] -arbPred n = frequency - [(1, return PTrue) - ,(1, return PFalse) - ,(2, fmap PAnd twoPreds) - ,(2, fmap POr twoPreds) - ,(2, fmap PNot (arbPred (n `div` 2))) - ,(2, liftM2 PImp (arbPred (n `div` 2)) (arbPred (n `div` 2))) - ,(2, liftM2 PIff (arbPred (n `div` 2)) (arbPred (n `div` 2))) - ,(2, fmap PBexp (arbExpr (n `div` 2))) - ,(2, liftM3 PAtom arbitrary (arbExpr (n `div` 2)) (arbExpr (n `div` 2))) - -- ,liftM2 PAll arbitrary arbitrary - -- ,return PTop - ] - where - twoPreds = do - x <- arbPred (n `div` 2) - y <- arbPred (n `div` 2) - return [x,y] - -instance Arbitrary Expr where - arbitrary = sized arbExpr - shrink = filter valid . genericShrink - where valid (EApp _ []) = False - valid _ = True - -arbExpr 0 = oneof [fmap ESym arbitrary, fmap ECon arbitrary, fmap EVar arbitrary, return EBot] -arbExpr n = frequency - [(1, fmap ESym arbitrary) - ,(1, fmap ECon arbitrary) - ,(1, fmap EVar arbitrary) - ,(1, return EBot) - -- ,liftM2 ELit arbitrary arbitrary -- restrict literals somehow - ,(2, choose (1,3) >>= \m -> liftM2 EApp arbitrary (vectorOf m (arbExpr (n `div` 2)))) - ,(2, liftM3 EBin arbitrary (arbExpr (n `div` 2)) (arbExpr (n `div` 2))) - ,(2, liftM3 EIte (arbPred (max 2 (n `div` 2)) `suchThat` isRel) - (arbExpr (n `div` 2)) - (arbExpr (n `div` 2))) - ,(2, liftM2 ECst (arbExpr (n `div` 2)) (arbSort (n `div` 2))) - ] - where - isRel (PAtom _ _ _) = True - isRel _ = False - -instance Arbitrary Brel where - arbitrary = oneof (map return [Eq, Ne, Gt, Ge, Lt, Le, Ueq, Une]) - -instance Arbitrary Bop where - arbitrary = oneof (map return [Plus, Minus, Times, Div, Mod]) - -instance Arbitrary SymConst where - arbitrary = fmap SL arbitrary - -instance Arbitrary Symbol where - arbitrary = fmap (symbol :: Text -> Symbol) arbitrary - -instance Arbitrary Text where - arbitrary = choose (1,4) >>= \n -> - fmap pack (vectorOf n char `suchThat` valid) - where - char = elements ['a'..'z'] - valid x = x `notElem` fixpointNames && not (isFixKey x) - -instance Arbitrary FTycon where - arbitrary = do - c <- elements ['A'..'Z'] - t <- arbitrary - return $ symbolFTycon $ dummyLoc $ symbol $ cons c t - -instance Arbitrary Constant where - arbitrary = oneof [fmap I (arbitrary `suchThat` (>=0)) - -- ,fmap R arbitrary - ] - shrink = genericShrink - -instance Arbitrary a => Arbitrary (Located a) where - arbitrary = fmap dummyLoc arbitrary - shrink = fmap dummyLoc . shrink . val - --} +elimCmd (LO opts) bin dir file = + printf "cd %s && %s --eliminate=some %s %s" dir bin opts file ---------------------------------------------------------------------------------------- -- Generic Helpers ---------------------------------------------------------------------------------------- +group :: Monad f => TestName -> [f TestTree] -> f TestTree group n xs = testGroup n <$> sequence xs ---------------------------------------------------------------------------------------- @@ -333,9 +218,9 @@ Const summary <$ State.modify (+ 1) - runGroup _ group children = Traversal $ Functor.Compose $ do + runGroup _ group' children = Traversal $ Functor.Compose $ do Const soFar <- Functor.getCompose $ getTraversal children - pure $ Const $ map (\(n,t,s) -> (groupn,t,s)) soFar + pure $ Const $ map (\(n,t,s) -> (group' n,t,s)) soFar computeFailures :: StatusMap -> IO Int computeFailures = fmap getSum . getApp . foldMap (\var -> Ap $ @@ -357,10 +242,7 @@ tree return $ \_elapsedTime -> do - -- get some semblance of a hostname - host <- takeWhile (/='.') . takeWhile (not . isSpace) <$> readProcess "hostname" [] [] -- don't use the `time` package, major api differences between ghc 708 and 710 - time <- head . lines <$> readProcess "date" ["+%Y-%m-%dT%H-%M-%S"] [] -- build header ref <- gitRef timestamp <- gitTimestamp @@ -373,12 +255,10 @@ "test, time(s), result"] - let dir = "tests" "logs" host ++ "-" ++ time let smry = "tests" "logs" "cur" "summary.csv" writeFile smry $ unlines $ hdr : map (\(n, t, r) -> printf "%s, %0.4f, %s" n t (show r)) summary - -- system $ "cp -r tests/logs/cur " ++ dir (==0) <$> computeFailures smap @@ -404,7 +284,7 @@ -- | Calls `git` for info; returns `"plain"` if we are not in a git directory. gitProcess :: [String] -> IO String -gitProcess args = (readProcess "git" args []) `catchIOError` const (return "plain") +gitProcess args = readProcess "git" args [] `catchIOError` const (return "plain") notNoise :: Char -> Bool notNoise a = a /= '\"' && a /= '\n' && a /= '\r' diff --git a/tests/todo-crash/wl01.fq b/tests/todo-crash/wl01.fq deleted file mode 100644 --- a/tests/todo-crash/wl01.fq +++ /dev/null @@ -1,39 +0,0 @@ -qualif Nat(v:int) : (0 <= v) - -bind 0 x : {v: int | [$k0]} -bind 1 y : {v: int | [$k0]} -bind 2 z : {v: int | [$k1]} - -constraint: - env [ ] - lhs {v : int | [v = 10]} - rhs {v : int | [$k0]} - id 1 tag [0] - -constraint: - env [ 0 ] - lhs {v : int | [v = x + x]} - rhs {v : int | [$k0]} - id 2 tag [0] - -constraint: - env [ 0; 1 ] - lhs {v : int | [v = x + y ]} - rhs {v : int | [$k1]} - id 3 tag [0] - - -constraint: - env [ 1 ] - lhs {v : int | [v = z]} - rhs {v : int | [0 <= v]} - id 4 tag [0] - -wf: - env [ ] - reft {v: int | [$k0]} - - -wf: - env [ ] - reft {v: int | [$k1]} diff --git a/tests/todo/LH1090.fq b/tests/todo/LH1090.fq deleted file mode 100644 --- a/tests/todo/LH1090.fq +++ /dev/null @@ -1,17 +0,0 @@ -// This test works on z3-4.4.1, but is broken in 4.4.2 or newer - -data Either 2 = [ - | right { eRight : @(0) } - | left { eLeft : @(1) } -] - -bind 0 escobar : {v:int | true } -bind 1 junk : {v:Either bool int | v = left escobar} -bind 2 punk : {v:Either int int | true} - -constraint: - env [0; 1; 2] - lhs {v:int | true } - rhs {v:int | punk = left escobar } - id 1 tag [] - diff --git a/tests/todo/T1371-short.fq b/tests/todo/T1371-short.fq deleted file mode 100644 --- a/tests/todo/T1371-short.fq +++ /dev/null @@ -1,78 +0,0 @@ -// minimized version of LH #1371 - -fixpoint "--rewrite" - -data Thing 0 = [ - | Op { opLeft : Thing, opRight : Thing} - | N { eNum : int} - ] - -// ACTUAL -define killer (arg1 : Thing, arg2 : Thing) : Thing = { - if (is$N arg1) - then (if (is$N arg2) then (arg1) else (Op (opLeft arg2) (killer (N (eNum arg1)) (opRight arg2)))) - else (Op (opLeft arg1) (killer (opRight arg1) arg2)) -} - -constant killer : (func(0 , [Thing; Thing; Thing])) - -match is$Op N x = (false) -match eNum N x = (x) -match is$N N x = (true) -match N x = ((N x)) -match opRight Op x y = (y) -match opLeft Op x y = (x) -match is$Op Op x y = (true) -match is$N Op x y = (false) - -bind 0 arg2 : {v : Thing | []} -bind 1 e1 : {v : Thing | []} -bind 2 e2 : {v : Thing | []} -bind 3 dY1 : {v : Thing | [((1 + 2) = 3); - (v = (killer e2 arg2)); - (v = (if (is$N e2) then (Op (opLeft arg2) (killer (N (eNum e2)) (opRight arg2))) else (Op (opLeft e2) (killer (opRight e2) arg2)))); - (v = (killer e2 arg2))]} - - - - - -bind 39 tmp : {v : Thing | [ ((opRight v) = e2); - ((opLeft v) = e1); - ((is$Op v) <=> true); - ((is$N v) <=> false); - (v = (Op e1 e2)); - (v = (Op e1 e2)); - ((opRight v) = e2); - ((opLeft v) = e1); - ((is$Op v) <=> true); - ((is$N v) <=> false); - (v = (Op e1 e2))]} - - -bind 40 n : {v : int | []} - -bind 50 dXY : {v : Thing | [((is$Op v) <=> false); - ((eNum v) = n); - ((is$N v) <=> true); - (v = (N n))]} - -bind 60 dXZ : {v : Thing | [((1 + 2) = 3); - (v = (killer dXY e2)); - (v = (if (is$N dXY) - then (Op (opLeft e2) (killer (N (eNum dXY)) (opRight e2))) - else (Op (opLeft dXY) (killer (opRight dXY) e2)))); - (v = (killer dXY e2))]} - -expand [8 : True] - -constraint: - env [0; 1; 2; 39;40; 50; 60] - lhs {VV8 : Thing | [((opRight VV8) = dXZ); - ((opLeft VV8) = e1); - ((is$Op VV8) <=> true); - ((is$N VV8) <=> false); - (VV8 = (Op e1 dXZ))]} - rhs {VV8 : Thing | [((10 + 2) = 3)]} - id 8 tag [3] - // META constraint id 8 : () diff --git a/tests/todo/ebind-kvar-chain.fq b/tests/todo/ebind-kvar-chain.fq deleted file mode 100644 --- a/tests/todo/ebind-kvar-chain.fq +++ /dev/null @@ -1,39 +0,0 @@ -fixpoint "--eliminate=some" - -ebind 15 n : { int } - -bind 16 m : { _ : int | true } -bind 18 one : { v : int | v = 1 } - -constraint: - env [15] - lhs {v3 : int | v3 = n } - rhs {v3 : int | $k2[vk2:=v3] } - id 3 tag [] - -constraint: - env [15] - lhs {v4 : int | $k1[vk1:=v4] } - rhs {v4 : int | v4 = n } - id 4 tag [] - -constraint: - env [16; 18] - lhs {v5 : int | v5 = m + 1 } - rhs {v5 : int | $k1[vk1:=v5] } - id 5 tag [] - -constraint: - env [16; 18] - lhs {v6 : int | $k2[vk2:=v6] } - rhs {v6 : int | v6 = m + 10000 } - id 6 tag [] - -wf: - env [16] - reft {vk1 : int | [$k1]} - -wf: - env [16] - reft {vk2 : int | [$k2]} - diff --git a/unix/Language/Fixpoint/Utils/Progress.hs b/unix/Language/Fixpoint/Utils/Progress.hs --- a/unix/Language/Fixpoint/Utils/Progress.hs +++ b/unix/Language/Fixpoint/Utils/Progress.hs @@ -19,27 +19,27 @@ withProgress :: Int -> IO a -> IO a withProgress n act = do - showBar <- ((/=) Quiet) <$> getVerbosity - case showBar of - False -> act - True -> displayConsoleRegions $ do + showBar <- (Quiet /=) <$> getVerbosity + if showBar + then displayConsoleRegions $ do -- putStrLn $ "withProgress: " ++ show n progressInit n r <- act progressClose return r - + else act + progressInit :: Int -> IO () progressInit n = do - normal <- isNormal + normal <- isNormal when normal $ do pr <- mkPB n writeIORef pbRef (Just pr) mkPB :: Int -> IO ProgressBar -mkPB n = newProgressBar def +mkPB n = newProgressBar def { pgWidth = 80 - , pgTotal = {- traceShow "MAKE-PROGRESS" -} (toInteger n) + , pgTotal = {- traceShow "MAKE-PROGRESS" -} toInteger n , pgFormat = "Working :percent [:bar]" , pgPendingChar = '.' , pgOnCompletion = Nothing @@ -51,15 +51,15 @@ go (Just pr) = incTick pr go _ = return () -incTick :: ProgressBar -> IO () +incTick :: ProgressBar -> IO () incTick pb = do - st <- getProgressStats pb + st <- getProgressStats pb when (incomplete st) (tick pb) -- then tick pb -- putStrLn (show (stPercent st, stTotal st, stCompleted st)) >> (tick pb) - -- else return () + -- else return () -incomplete :: Stats -> Bool -incomplete st = {- traceShow "INCOMPLETE" -} (stRemaining st) > 0 +incomplete :: Stats -> Bool +incomplete st = {- traceShow "INCOMPLETE" -} stRemaining st > 0 -- incomplete st = stPercent st < 100