packages feed

liquid-fixpoint 0.8.10.2 → 8.10.7

raw patch · 168 files changed

Files

+ .circleci/config.yml view
@@ -0,0 +1,53 @@+---+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
+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc
+ CHANGES.md view
@@ -0,0 +1,47 @@+# 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.
+ README.md view
@@ -0,0 +1,366 @@+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}+```
+ TODO.md view
@@ -0,0 +1,2 @@+# TODO+
bin/Fixpoint.hs view
@@ -24,7 +24,7 @@       | otherwise  = solveFQ   isHorn :: F.Config -> Bool -isHorn = F.isExtFile F.Smt2 . F.srcFile+isHorn cfg = F.isExtFile F.Smt2 (F.srcFile cfg) || F.stdin cfg   errorExit :: F.Error -> IO ExitCode errorExit e = do
+ default.nix view
@@ -0,0 +1,52 @@+{ 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
+ git-0.3.0_fix-monad-fail-for-ghc-8.10.1.patch view
@@ -0,0 +1,13 @@+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
+ hie.yaml view
@@ -0,0 +1,8 @@+cradle:+  stack:+    - path: "./src"+      component: "liquid-fixpoint:lib"+    - path: "./bin"+      component: "liquid-fixpoint:exe:fixpoint"+    - path: "./tests"+      component: "liquid-fixpoint:test:test"
liquid-fixpoint.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               liquid-fixpoint-version:            0.8.10.2+version:            8.10.7 synopsis:           Predicate Abstraction-based Horn-Clause/Implication Constraint Solver description:   This package implements an SMTLIB based Horn-Clause\/Logical Implication constraint@@ -21,7 +21,7 @@ copyright:          2010-17 Ranjit Jhala, University of California, San Diego. 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+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 build-type:         Simple@@ -43,7 +43,8 @@  library   autogen-modules:  Paths_liquid_fixpoint-  exposed-modules:  Language.Fixpoint.Defunctionalize+  exposed-modules:  Data.ShareMap+                    Language.Fixpoint.Defunctionalize                     Language.Fixpoint.Graph                     Language.Fixpoint.Graph.Deps                     Language.Fixpoint.Graph.Indexed@@ -65,11 +66,13 @@                     Language.Fixpoint.Smt.Types                     Language.Fixpoint.Solver                     Language.Fixpoint.Solver.Eliminate+                    Language.Fixpoint.Solver.EnvironmentReduction                     Language.Fixpoint.Solver.GradualSolution                     Language.Fixpoint.Solver.Instantiate                     Language.Fixpoint.Solver.PLE                     Language.Fixpoint.Solver.Monad                     Language.Fixpoint.Solver.Rewrite+                    Language.Fixpoint.Solver.Prettify                     Language.Fixpoint.Solver.Sanitize                     Language.Fixpoint.Solver.Solution                     Language.Fixpoint.Solver.Solve@@ -98,6 +101,7 @@                     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@@ -111,6 +115,8 @@                   , async                   , attoparsec                   , binary+                  , store+                  , bytestring                   , boxes                   , cereal                   , cmdargs@@ -123,15 +129,18 @@                   , intern                   , mtl                   , parallel-                  , parsec+                  , parser-combinators+                  , megaparsec           >= 7.0.0 && < 9                   , pretty               >= 1.1.3.1                   , process+                  , stm                   , syb                   , syb                   , text-                  , text-format                   , transformers                   , unordered-containers+                  , aeson+                  , rest-rewrite >= 0.1.1   default-language: Haskell98   ghc-options:      -W -fno-warn-missing-methods -fwarn-missing-signatures @@ -160,6 +169,7 @@   main-is:          test.hs   other-modules:    Paths_liquid_fixpoint   hs-source-dirs:   tests+  build-tool-depends: liquid-fixpoint:fixpoint   build-depends:    base          >= 4.9.1.0 && < 5                   , containers    >= 0.5                   , directory@@ -179,15 +189,20 @@   if flag(devel)     ghc-options: -Werror -test-suite testparser+test-suite tasty   type:             exitcode-stdio-1.0-  main-is:          testParser.hs-  hs-source-dirs:   tests+  main-is:          Main.hs+  other-modules:    ParserTests+                    ShareMapReference+                    ShareMapTests+  hs-source-dirs:   tests/tasty   build-depends:    base            >= 4.9.1.0 && < 5+                  , hashable                   , liquid-fixpoint                   , tasty           >= 0.10-                  , tasty-hunit+                  , tasty-quickcheck                   , tasty-hunit     >= 0.9+                  , unordered-containers   default-language: Haskell98   ghc-options:      -threaded
+ scripts/travis view
@@ -0,0 +1,137 @@+#!/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 "$@"+
+ shell.nix view
@@ -0,0 +1,1 @@+import ./. { makeEnv = true; }
+ src/Data/ShareMap.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.ShareMap+  ( ShareMap+  , empty+  , toHashMap+  , insertWith+  , map+  , mergeKeysWith+  ) where++import           Data.Hashable (Hashable)+import           Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import           Data.Maybe (fromMaybe)+import           Prelude hiding (map)++-- | A HashMap that can share the values of some entries+--+-- If two keys @k1@ and @k2@ are mapped to single @v@, updating+-- the entry for @k1@ also updates the entry for @k2@ and viceversa.+--+-- The user of the map is responsible for indicating which keys are+-- going to share their values.+--+-- Keys can be updated with 'shareMapInsertWith' and 'mergeKeysWith'.+data ShareMap k v = ShareMap+  { -- | @(k, v)@ pairs in the map.+    --+    -- Contains at least an entry for each key in the values of+    -- of 'shareMap'.+    unsharedMap :: HashMap (InternalKey k) v+  , -- | If @k1@ is mapped to @k2@, then both keys are considered+    -- associated to the value of @k2@ in 'unsharedMap'.+    --+    -- Contains an entry for each key in the 'ShareMap'.+    shareMap :: ReversibleMap k (InternalKey k)+  }+  deriving Show++-- | This are the only keys that can be used in internal maps+newtype InternalKey k = InternalKey k+  deriving (Eq, Hashable)++instance Show k => Show (InternalKey k) where+  show (InternalKey k) = show k++empty :: ShareMap k v+empty = ShareMap HashMap.empty emptyReversibleMap++toHashMap :: (Hashable k, Eq k) => ShareMap k v -> HashMap k v+toHashMap sm =+  HashMap.foldlWithKey' expand HashMap.empty (directMap $ shareMap sm)+  where+    expand m k k' =+      maybe m (\v -> HashMap.insert k v m) (HashMap.lookup k' $ unsharedMap sm)++-- | @insertWith f k v m@ is the map @m@ plus key @k@ being associated to+-- value @v@.+--+-- If @k@ is present in @m@, then @k@ and any other key sharing its value+-- will be associated to @f v (m ! k)@.+--+insertWith+  :: (Hashable k, Eq k)+  => (v -> v -> v)+  -> k+  -> v+  -> ShareMap k v+  -> ShareMap k v+insertWith f k v sm =+  case HashMap.lookup k $ directMap $ shareMap sm of+    Just k' -> sm+      { unsharedMap = HashMap.insertWith f k' v (unsharedMap sm)+      }+    Nothing -> ShareMap+      { unsharedMap = HashMap.insertWith f (InternalKey k) v (unsharedMap sm)+      , shareMap = insertReversibleMap k (InternalKey k) (shareMap sm)+      }++-- | @mergeKeysWith f k0 k1 m@ updates the @k0@ value to @f (m ! k0) (m ! k1)@+-- and @k1@ shares the value with @k0@.+--+-- If @k0@ and @k1@ are already sharing their values in @m@, or both keys are+-- missing, this operation returns @m@ unmodified.+--+-- If only one of the keys is present, the other key is associated with the+-- existing value.+mergeKeysWith+  :: (Hashable k, Eq k)+  => (v -> v -> v)+  -> k+  -> k+  -> ShareMap k v+  -> ShareMap k v+mergeKeysWith f k0 k1 sm | k0 /= k1 =+  case lookupReversibleMap k1 (shareMap sm) of+    Just k1' | InternalKey k0 /= k1' -> case HashMap.lookup k1' (unsharedMap sm) of+      Just v1 -> case lookupReversibleMap k0 (shareMap sm) of+        Just k0' | k0' /= k1' ->+          ShareMap+            { unsharedMap = HashMap.insertWith (flip f) k0' v1 (unsharedMap sm)+            , shareMap = -- Any values pointing to k1 are redirected to k0':+                HashSet.foldl' (\m k -> insertReversibleMap k k0' m) (shareMap sm) $+                reverseLookup k1' $ shareMap sm+            }+        Nothing ->+          sm { shareMap = insertReversibleMap k0 k1' (shareMap sm) }+        _ ->+          sm+      Nothing -> error "mergeKeysWith: broken invariant: unexpected missing key in unsharedMap"+    Nothing ->+      case HashMap.lookup k0 (directMap $ shareMap sm) of+        Just k0' ->+          sm { shareMap = insertReversibleMap k1 k0' (shareMap sm) }+        Nothing ->+          sm+    _ ->+      sm+mergeKeysWith _ _ _ sm = sm++map :: (a -> b) -> ShareMap k a -> ShareMap k b+map f sm = sm { unsharedMap = HashMap.map f (unsharedMap sm) }++-- | A map with an efficient 'reverseLookup'+data ReversibleMap k v = ReversibleMap+  { directMap :: HashMap k v+  , -- |+    -- > forall (v, ks) in reversedMap.+    -- >   forall k in ks.+    -- >     (k, v) is in directMap+    reversedMap :: HashMap v (HashSet k)+  }+  deriving Show++emptyReversibleMap :: ReversibleMap k v+emptyReversibleMap = ReversibleMap HashMap.empty HashMap.empty++insertReversibleMap+  :: (Hashable k, Eq k, Hashable v, Eq v)+  => k+  -> v+  -> ReversibleMap k v+  -> ReversibleMap k v+insertReversibleMap k v rm = ReversibleMap+  { directMap = HashMap.insert k v (directMap rm)+  , reversedMap =+      let m' = case HashMap.lookup k (directMap rm) of+            Nothing -> reversedMap rm+            Just oldv -> HashMap.adjust (HashSet.delete k) oldv (reversedMap rm)+       in HashMap.insertWith HashSet.union v (HashSet.singleton k) m'+  }++reverseLookup :: (Hashable v, Eq v) => v -> ReversibleMap k v -> HashSet k+reverseLookup v rm = fromMaybe HashSet.empty $ HashMap.lookup v (reversedMap rm)++lookupReversibleMap :: (Hashable k, Eq k) => k -> ReversibleMap k v -> Maybe v+lookupReversibleMap k rm = HashMap.lookup k (directMap rm)
+ src/Language/Fixpoint/Congruence/Closure.hs view
@@ -0,0 +1,67 @@+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'+
+ src/Language/Fixpoint/Congruence/Types.hs view
@@ -0,0 +1,100 @@+{-# 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+
src/Language/Fixpoint/Graph/Deps.hs view
@@ -152,6 +152,10 @@  -------------------------------------------------------------------------------- -- | Ranks from Graph ----------------------------------------------------------+--+-- Yields the strongly conected components and a map of constraint ids to+-- an index identifying the strongly connected component to which it belongs.+-- The scc indices correspond with a topological ordering of the sccs. -------------------------------------------------------------------------------- graphRanks :: G.Graph -> (G.Vertex -> DepEdge) -> (CMap Int, [[G.Vertex]]) ---------------------------------------------------------------------------@@ -173,15 +177,15 @@     cm    = F.cm     fi  succs :: (F.TaggedC c a) => CMap (c a) -> KVRead -> CMap [F.SubcId]-succs cm rdBy = (sortNub . concatMap kvReads . kvWrites) <$> cm+succs cm rdBy = sortNub . concatMap kvReads . kvWrites <$> cm   where     kvReads k = M.lookupDefault [] k rdBy-    kvWrites  = V.kvars . F.crhs+    kvWrites  = V.kvarsExpr . F.crhs  -------------------------------------------------------------------------------- kvWriteBy :: (F.TaggedC c a) => CMap (c a) -> F.SubcId -> [F.KVar] ---------------------------------------------------------------------------------kvWriteBy cm = V.kvars . F.crhs . lookupCMap cm+kvWriteBy cm = V.kvarsExpr . F.crhs . lookupCMap cm  -------------------------------------------------------------------------------- kvReadBy :: (F.TaggedC c a) => F.GInfo c a -> KVRead@@ -206,6 +210,7 @@ edgeGraph es = KVGraph [(v, v, vs) | (v, vs) <- groupList es ]  -- need to plumb list of ebinds+{-# SCC kvEdges #-} kvEdges :: (F.TaggedC c a) => F.GInfo c a -> [CEdge] kvEdges fi = selfes ++ concatMap (subcEdges bs) cs ++ concatMap (ebindEdges ebs bs) cs   where@@ -244,6 +249,7 @@ -------------------------------------------------------------------------------- -- | Eliminated Dependencies --------------------------------------------------------------------------------+{-# SCC elimDeps #-} elimDeps :: (F.TaggedC c a) => F.GInfo c a -> [CEdge] -> S.HashSet F.KVar -> S.HashSet F.Symbol -> CDeps elimDeps si es nonKutVs ebs = graphDeps si es'   where@@ -308,6 +314,7 @@ -------------------------------------------------------------------------------- -- | Compute Dependencies and Cuts --------------------------------------------- --------------------------------------------------------------------------------+{-# SCC elimVars #-} elimVars :: (F.TaggedC c a) => Config -> F.GInfo c a -> ([CEdge], Elims F.KVar) -------------------------------------------------------------------------------- elimVars cfg si = (es, ds)@@ -329,6 +336,7 @@ forceKuts :: (Hashable a, Eq a) => S.HashSet a -> Elims a  -> Elims a forceKuts xs (Deps cs ns) = Deps (S.union cs xs) (S.difference ns xs) +{-# SCC edgeDeps #-} edgeDeps :: (F.TaggedC c a) => Config -> F.GInfo c a -> [CEdge] -> Elims F.KVar edgeDeps cfg si  = forceKuts ks                  . edgeDeps' cfg@@ -485,7 +493,10 @@     is          = [i | (Cstr i, _) <- cs]     cPrevM      = sortNub <$> group [ (i, k) | (KVar k, Cstr i) <- cs ] ---TODO merge these with cGraph and kvSucc+-- | Converts dependencies between constraints and kvars, to dependencies between+-- constraints.+--+-- TODO merge these with cGraph and kvSucc cGraphCE :: [CEdge] -> CGraph cGraphCE cs = CGraph { gEdges = es                      , gRanks = outRs@@ -497,6 +508,11 @@     (g, vf, _)     = G.graphFromEdges es     (outRs, sccs)  = graphRanks g vf +-- | Converts dependencies between constraints and kvars to+-- dependencies between constraints.+--+-- 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   where@@ -512,6 +528,7 @@     tag           = F.stag . lookupCMap cm  ---------------------------------------------------------------------------+-- | Removes the kut vars from the graph, and recomputes the SCC indices. inRanks ::  F.TaggedC c a => F.GInfo c a -> [DepEdge] -> CMap Int -> CMap Int --------------------------------------------------------------------------- inRanks fi es outR
src/Language/Fixpoint/Graph/Reducible.hs view
@@ -59,4 +59,4 @@  subcEdges' :: (F.TaggedC c a) => (F.KVar -> Node) -> F.BindEnv -> c a -> [(Node, Node)] subcEdges' kvI be c = [(kvI k1, kvI k2) | k1 <- V.envKVars be c-                                        , k2 <- V.kvars $ F.crhs c]+                                        , k2 <- V.kvarsExpr $ F.crhs c]
src/Language/Fixpoint/Graph/Types.hs view
@@ -132,6 +132,10 @@ -- | Dramatis Personae --------------------------------------------------------------------------- type KVRead  = M.HashMap F.KVar [F.SubcId]+-- | (Constraint id, vertex key, edges to other constraints)+--+-- The vertex key is always equal to the constraint id. The redundancy+-- is imposed by how @containers:Data.Graph@ requires graphs to be created. type DepEdge = (F.SubcId, F.SubcId, [F.SubcId])  data Slice = Slice { slKVarCs :: [F.SubcId]     -- ^ F.SubcIds that transitively "reach" below@@ -139,11 +143,21 @@                    , slEdges  :: [DepEdge] -- ^ Dependencies between slKVarCs                    } deriving (Eq, Show) -data CGraph = CGraph { gEdges :: [DepEdge]-                     , gRanks :: !(F.CMap Int)-                     , gSucc  :: !(F.CMap [F.SubcId])-                     , gSccs  :: !Int-                     }+data CGraph = CGraph+  { gEdges :: [DepEdge]+    -- | Maps a constraint id to an index identifying the strongly connected+    -- component to which it belongs.+    -- The scc indices correspond with a topological ordering of the sccs.+  , gRanks :: !(F.CMap Int)+    -- | Tells for each constraint C, which constraints read any kvars that+    -- C writes.+    --+    -- This is redundant with 'gEdges', so both fields need to express the+    -- exact same dependencies.+  , gSucc  :: !(F.CMap [F.SubcId])+    -- | Amount of strongly connected components+  , gSccs  :: !Int+  }  --------------------------------------------------------------------------- -- | CMap API -------------------------------------------------------------
src/Language/Fixpoint/Horn/Info.hs view
@@ -16,23 +16,33 @@ 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 -hornFInfo :: H.Query a -> F.FInfo a-hornFInfo q    = mempty-  { F.cm       = cs-  , F.bs       = be2-  , F.ebinds   = ebs-  , F.ws       = kvEnvWfCs kve-  , F.quals    = H.qQuals q-  , F.gLits    = F.fromMapSEnv $ H.qCon q-  , F.dLits    = F.fromMapSEnv $ H.qDis q+hornFInfo :: F.Config -> H.Query a -> F.FInfo a+hornFInfo cfg q = mempty+  { F.cm        = cs+  , F.bs        = be2+  , F.ebinds    = ebs+  , F.ws        = kvEnvWfCs kve+  , F.quals     = H.qQuals q+  , F.gLits     = F.fromMapSEnv $ H.qCon q+  , F.dLits     = F.fromMapSEnv $ H.qDis q+  , F.ae        = axEnv cfg q cs+  , F.ddecls    = H.qData q   }   where-    be0        = F.emptyBindEnv-    (be1, kve) = hornWfs   be0     (H.qVars q)+    be0         = F.emptyBindEnv+    (be1, kve)  = hornWfs   be0     (H.qVars q)     (be2, ebs, cs) = hornSubCs be1 kve hCst-    hCst       = H.qCstr q+    hCst           = H.qCstr q++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+  }   ---------------------------------------------------------------------------------- hornSubCs :: F.BindEnv -> KVEnv a -> H.Cstr a
src/Language/Fixpoint/Horn/Parse.hs view
@@ -1,16 +1,23 @@  {-# LANGUAGE DeriveFunctor #-} -module Language.Fixpoint.Horn.Parse (hornP) where +module Language.Fixpoint.Horn.Parse (+    hornP+  , hCstrP+  , hPredP+  , hQualifierP+  , hVarP+) where  import           Language.Fixpoint.Parse-import qualified Language.Fixpoint.Types        as F -import qualified Language.Fixpoint.Horn.Types   as H -import           Text.Parsec       hiding (State)+import qualified Language.Fixpoint.Types        as F+import qualified Language.Fixpoint.Horn.Types   as H+import           Text.Megaparsec                hiding (State)+import           Text.Megaparsec.Char           (char) import qualified Data.HashMap.Strict            as M  --------------------------------------------------------------------------------hornP :: Parser (H.Query (), [String])+hornP :: Parser (H.TagQuery, [String]) ------------------------------------------------------------------------------- hornP = do   hThings <- many hThingP@@ -18,11 +25,14 @@  mkQuery :: [HThing a] -> H.Query a mkQuery things = H.Query-  { H.qQuals =        [ q | HQual q <- things ] -  , H.qVars  =        [ k | HVar  k <- things ] -  , 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.qQuals =            [ q     | HQual q  <- things ]+  , H.qVars  =            [ k     | HVar  k  <- things ]+  , 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.qData  =            [ dd    | HDat dd <- things ]   }  -- | A @HThing@ describes the kinds of things we may see, in no particular order@@ -32,75 +42,81 @@   = HQual !F.Qualifier   | HVar  !(H.Var a)   | HCstr !(H.Cstr a)-  +   -- for uninterpred functions and ADT constructors   | HCon  F.Symbol F.Sort   | HDis  F.Symbol F.Sort-+  | HDef  F.Equation +  | HMat  F.Rewrite+  | HDat  F.DataDecl   | HOpt !String   deriving (Functor) -hThingP :: Parser (HThing ())-hThingP  = parens body -  where +hThingP :: Parser (HThing H.Tag)+hThingP  = parens body+  where     body =  HQual <$> (reserved "qualif"     *> hQualifierP)         <|> HCstr <$> (reserved "constraint" *> hCstrP)         <|> HVar  <$> (reserved "var"        *> hVarP)         <|> HOpt  <$> (reserved "fixpoint"   *> stringLiteral)         <|> HCon  <$> (reserved "constant"   *> symbolP) <*> sortP         <|> HDis  <$> (reserved "distinct"   *> symbolP) <*> sortP+        <|> HDef  <$> (reserved "define"     *> defineP)+        <|> HMat  <$> (reserved "match"      *> matchP)+        <|> HDat  <$> (reserved "data"       *> dataDeclP)  --------------------------------------------------------------------------------hCstrP :: Parser (H.Cstr ())+hCstrP :: Parser (H.Cstr H.Tag) --------------------------------------------------------------------------------hCstrP = parens body -  where -    body =  H.CAnd  <$> (reserved "and"    *> many1 hCstrP)-        <|> H.All   <$> (reserved "forall" *> hBindP)       <*> hCstrP -        <|> H.Any   <$> (reserved "exists" *> hBindP)       <*> hCstrP -        <|> H.Head  <$> hPredP                              <*> pure ()+hCstrP = parens body+  where+    body =  H.CAnd <$> (reserved "and"    *> some 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   = parens $ do +hBindP   = parens $ do   (x, t) <- symSortP-  p      <- hPredP +  p      <- hPredP   return  $ H.Bind x t p-  + --------------------------------------------------------------------------------hPredP :: Parser H.Pred +hPredP :: Parser H.Pred --------------------------------------------------------------------------------hPredP = parens body -  where -    body =  H.Var  <$> kvSymP                           <*> many1 symbolP-        <|> H.PAnd <$> (reserved "and" *> many1 hPredP)-        <|> H.Reft <$> predP +hPredP = parens body+  where+    body =  H.Var  <$> kvSymP                           <*> some symbolP+        <|> H.PAnd <$> (reserved "and" *> some hPredP)+        <|> H.Reft <$> predP -kvSymP :: Parser F.Symbol -kvSymP = char '$' *> symbolP +kvSymP :: Parser F.Symbol+kvSymP = char '$' *> symbolP  ------------------------------------------------------------------------------- -- | Qualifiers ------------------------------------------------------------------------------- hQualifierP :: Parser F.Qualifier hQualifierP = do-  pos    <- getPosition+  pos    <- getSourcePos   n      <- upperIdP-  params <- parens (many1 symSortP) +  params <- parens (some symSortP)   body   <- parens predP   return  $ F.mkQual n (mkParam <$> params) body pos -mkParam :: (F.Symbol, F.Sort) -> F.QualParam +mkParam :: (F.Symbol, F.Sort) -> F.QualParam mkParam (x, t) = F.QP x F.PatNone t  ---------------------------------------------------------------------------------- | Horn Variables +-- | Horn Variables ------------------------------------------------------------------------------- -hVarP :: Parser (H.Var ())-hVarP = H.HVar <$> kvSymP <*> parens (many1 (parens sortP)) <*> pure ()+hVarP :: Parser (H.Var H.Tag)+hVarP = H.HVar <$> kvSymP <*> parens (some (parens sortP)) <*> pure H.NoTag   ---------------------------------------------------------------------------------- | Helpers +-- | Helpers -------------------------------------------------------------------------------  symSortP :: Parser (F.Symbol, F.Sort)
src/Language/Fixpoint/Horn/Solve.hs view
@@ -5,8 +5,11 @@  module Language.Fixpoint.Horn.Solve (solveHorn, solve) where -import           System.Exit-import           Control.DeepSeq+import System.Exit ( ExitCode )+import Control.DeepSeq ( NFData )+import Control.Monad (when)+import qualified Language.Fixpoint.Misc         as Misc+import qualified Language.Fixpoint.Utils.Files  as Files import qualified Language.Fixpoint.Solver       as Solver import qualified Language.Fixpoint.Parse        as Parse import qualified Language.Fixpoint.Types        as F@@ -14,9 +17,10 @@ import qualified Language.Fixpoint.Horn.Types   as H import qualified Language.Fixpoint.Horn.Parse   as H import qualified Language.Fixpoint.Horn.Transformations as Tx-import           Language.Fixpoint.Horn.Info+import Text.PrettyPrint.HughesPJ.Compat ( render )+import Language.Fixpoint.Horn.Info ( hornFInfo ) -import           System.Console.CmdArgs.Verbosity+import System.Console.CmdArgs.Verbosity ( whenLoud )  -- import Debug.Trace (traceM) @@ -24,26 +28,38 @@ solveHorn :: F.Config -> IO ExitCode ---------------------------------------------------------------------------------- solveHorn cfg = do-  (q, opts) <- Parse.parseFromFile H.hornP (F.srcFile cfg)-+  (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)+   r <- solve cfg q-  Solver.resultExitCode (fst <$> r)+  Solver.resultExitCode cfg r +parseQuery :: F.Config -> IO (H.Query H.Tag, [String])+parseQuery cfg +  | F.stdin cfg = Parse.parseFromStdIn H.hornP+  | otherwise   = Parse.parseFromFile H.hornP (F.srcFile cfg)++saveHornQuery :: F.Config -> H.Query H.Tag -> IO ()+saveHornQuery cfg q = do+  let hq   = F.queryFile Files.HSmt2 cfg+  putStrLn $ "Saving Horn Query: " ++ hq ++ "\n"+  Misc.ensurePath hq+  writeFile hq $ render (F.pprint q)+ ---------------------------------------------------------------------------------- eliminate :: (F.PPrint a) => F.Config -> H.Query a -> IO (H.Query a) ---------------------------------------------------------------------------------- eliminate cfg q   | F.eliminate cfg == F.Existentials = do-    q <- Tx.solveEbs cfg q-    -- b <- SI.checkValid cfg "/tmp/asdf.smt2" [] F.PTrue $ Tx.cstrToExpr side-    -- if b then print "checked side condition" else error "side failed"-    pure q+    Tx.solveEbs cfg q   | F.eliminate cfg == F.Horn = do     let c = Tx.elim $ H.qCstr q     whenLoud $ putStrLn "Horn Elim:"@@ -60,5 +76,5 @@   whenLoud $ putStrLn "Horn Uniq:"   whenLoud $ putStrLn $ F.showpp c   q <- eliminate cfg ({- void $ -} q { H.qCstr = c })-  Solver.solve cfg (hornFInfo q)+  Solver.solve cfg (hornFInfo cfg q)
src/Language/Fixpoint/Horn/Transformations.hs view
@@ -70,14 +70,14 @@  solveEbs :: (F.PPrint a) => F.Config -> Query a -> IO (Query a) -------------------------------------------------------------------------------solveEbs cfg query@(Query qs vs c cons dist) = do+solveEbs cfg query@(Query qs vs c cons dist eqns mats dds) = do   -- clean up   let normalizedC = flatten . pruneTauts $ hornify c   whenLoud $ putStrLn "Normalized EHC:"   whenLoud $ putStrLn $ F.showpp normalizedC    -- short circuit if no ebinds are present-  if isNNF c then pure $ Query qs vs normalizedC cons dist else do+  if isNNF c then pure $ Query qs vs normalizedC cons dist eqns mats dds else do   let kvars = boundKvars normalizedC    whenLoud $ putStrLn "Skolemized:"@@ -122,7 +122,7 @@   let solvedSide = substPiSols solvedPiCstrs side'   whenLoud $ putStrLn $ F.showpp solvedSide -  pure $ (Query qs vs (CAnd [solvedHorn, solvedSide]) cons dist)+  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)`@@ -137,8 +137,8 @@     go (CAnd cs) = (\(as, bs, cs) -> (concat as, concat bs, cAndMaybes cs)) $ unzip3 $ go <$> cs     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 = fmap (fmap (All b)) (go c')-    go (All b c') = fmap (fmap (All b)) (go c')+      | otherwise = map3 (fmap (All b)) (go c')+    go (All b c') = map3 (fmap (All b)) (go c')     go _ = ([], [], Nothing)      cAndMaybes :: [Maybe (Cstr a)] -> Maybe (Cstr a)@@ -146,10 +146,8 @@       [] -> Nothing       cs -> Just $ CAnd cs -#if !MIN_VERSION_base(4,14,0)-instance Functor ((,,) a b) where-    fmap f (a, b, c) = (a, b, f c)-#endif+map3 :: (c -> d) -> (a, b, c) -> (a, b, d)+map3 f (x, y, z) = (x, y, f z)  -- | Solve out the given pivars solPis :: S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> M.HashMap F.Symbol Pred@@ -923,9 +921,9 @@ isNNF Any{} = False  calculateCuts :: F.Config -> Query a -> Cstr a -> S.Set F.Symbol-calculateCuts cfg (Query qs vs _ cons dist) nnf = convert $ FG.depCuts deps+calculateCuts cfg (Query qs vs _ cons dist eqns mats dds) nnf = convert $ FG.depCuts deps   where-    (_, deps) = elimVars cfg (hornFInfo $ Query qs vs nnf cons dist)+    (_, deps) = elimVars cfg (hornFInfo cfg $ Query qs vs nnf cons dist eqns mats dds)     convert hashset = S.fromList $ F.kv <$> (HS.toList hashset)  forgetPiVars :: S.Set F.Symbol -> Cstr a -> Cstr a
src/Language/Fixpoint/Horn/Types.hs view
@@ -19,6 +19,11 @@   , Bind  (..)   , Var   (..)  +    -- * Raw Query+  , Tag (..)+  , TagVar+  , TagQuery +     -- * accessing constraint labels   , cLabel @@ -34,11 +39,15 @@ import           Data.Generics             (Data) import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic)+import           Control.DeepSeq ( NFData )+import qualified Data.Text               as T+import           Data.Maybe (fromMaybe) import qualified Data.List               as L import qualified Language.Fixpoint.Misc  as Misc import qualified Language.Fixpoint.Types as F import qualified Text.PrettyPrint.HughesPJ.Compat as P import qualified Data.HashMap.Strict as M+import           Data.Aeson  ------------------------------------------------------------------------------- -- | @HVar@ is a Horn variable @@ -190,10 +199,64 @@   , 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) +-- | Tag each query with a possible string denoting "provenance" +type TagVar   = Var Tag+type TagQuery = Query Tag+data Tag      = NoTag | Tag String+  deriving (Data, Typeable, Generic, Show) ++instance NFData Tag++instance F.Loc Tag where+  srcSpan _ = F.dummySpan++instance F.Fixpoint Tag where+  toFix NoTag   = "\"\"" +  toFix (Tag s) = "\"" <> P.text s <> "\""+  +instance F.PPrint Tag where+  pprintPrec _ _ NoTag   = mempty+  pprintPrec _ _ (Tag s) = P.ptext s ++instance ToJSON Tag where+  toJSON NoTag   = Null+  toJSON (Tag s) = String (T.pack s) ++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)]+    , ppThings Nothing (qEqns  q)+    , ppThings (Just "data ") (qData  q)+    , P.parens (P.vcat ["constraint", F.pprintPrec (k+2) t (qCstr q)])+    ]++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 ++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))++ppVar :: Var a -> P.Doc+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 -------------------------------------------------------------------------------@@ -221,16 +284,18 @@   pprintPrec _ _ v = P.ptext $ show v  instance F.PPrint Pred where-  pprintPrec k t (Reft p) = P.parens $ F.pprintPrec k t p+  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 k t (PAnd ps) = P.parens $ P.vcat $ P.ptext "and" : map (F.pprintPrec (k+2) t) ps+  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   pprintPrec k t (Head p _) = P.parens $ F.pprintPrec k t p-  pprintPrec k t (All b c) =-    P.parens $ P.vcat [P.ptext "forall" P.<+> F.pprintPrec (k+2) t b, F.pprintPrec (k+1) t c]-  pprintPrec k t (Any b c) =-    P.parens $ P.vcat [P.ptext "exists" P.<+> F.pprintPrec (k+2) t b, F.pprintPrec (k+1) t c]+  pprintPrec k t (All b c)  = P.parens $ P.vcat [ P.ptext "forall" P.<+> F.pprintPrec (k+2) t b+                                                , F.pprintPrec (k+1) t c+                                                ]+  pprintPrec k t (Any b c)  = P.parens $ P.vcat [P.ptext "exists" P.<+> F.pprintPrec (k+2) t b+                                                , F.pprintPrec (k+1) t c+                                                ]   pprintPrec k t (CAnd cs) = P.parens $ P.vcat  $ P.ptext "and" : map (F.pprintPrec (k+2) t) cs  instance F.PPrint Bind where
src/Language/Fixpoint/Misc.hs view
@@ -79,6 +79,7 @@ -- | Edit Distance -------------------------------------------- --------------------------------------------------------------- +{-# SCC editDistance #-} editDistance :: Eq a => [a] -> [a] -> Int editDistance xs ys = table ! (m, n)     where@@ -181,10 +182,10 @@ mfromJust s Nothing  = errorstar $ "mfromJust: Nothing " ++ s  inserts ::  (Eq k, Hashable k) => k -> v -> M.HashMap k [v] -> M.HashMap k [v]-inserts k v m = M.insert k (v : M.lookupDefault [] k m) m+inserts k v m = M.insertWith (const (v:)) k [v] m  removes ::  (Eq k, Hashable k, Eq v) => k -> v -> M.HashMap k [v] -> M.HashMap k [v]-removes k v m = M.insert k (L.delete v (M.lookupDefault [] k m)) m+removes k v m = M.insertWith (const (L.delete v)) k [] m  count :: (Eq k, Hashable k) => [k] -> [(k, Int)] count = M.toList . fmap sum . group . fmap (, 1)@@ -209,6 +210,9 @@  sortNub :: (Ord a) => [a] -> [a] sortNub = nubOrd . L.sort++sortNubBy :: (Eq a) => (a -> a -> Ordering) -> [a] -> [a]+sortNubBy f = nubOrd . L.sortBy f  nubOrd :: (Eq a) => [a] -> [a] nubOrd (x:t@(y:_))
src/Language/Fixpoint/Parse.hs view
@@ -15,1080 +15,1542 @@   -- * Top Level Class for Parseable Values   , Parser -  -- * Lexer to add new tokens-  , lexer--  -- * Some Important keyword and parsers-  , reserved, reservedOp-  , parens  , brackets, angles, braces-  , semi    , comma-  , colon   , dcolon-  , whiteSpace-  , blanks-  , pairP-  , stringLiteral--  -- * Parsing basic entities--  --   fTyConP  -- Type constructors-  , lowerIdP    -- Lower-case identifiers-  , upperIdP    -- Upper-case identifiers-  , infixIdP    -- String Haskell infix Id-  , symbolP     -- Arbitrary Symbols-  , constantP   -- (Integer) Constants-  , integer     -- Integer-  , bindP       -- Binder (lowerIdP <* colon)-  , sortP       -- Sort-  , mkQual      -- constructing qualifiers-  , infixSymbolP -- parse infix symbols --  -- * Parsing recursive entities-  , exprP       -- Expressions-  , predP       -- Refinement Predicates-  , funAppP     -- Function Applications-  , qualifierP  -- Qualifiers-  , refaP       -- Refa-  , refP        -- (Sorted) Refinements-  , refDefP     -- (Sorted) Refinements with default binder-  , refBindP    -- (Sorted) Refinements with configurable sub-parsers-  , bvSortP     -- Bit-Vector Sort--  -- * Some Combinators-  , condIdP     --  condIdP  :: [Char] -> (Text -> Bool) -> Parser Text--  -- * Add a Location to a parsed value-  , locParserP-  , locLowerIdP-  , locUpperIdP--  -- * Getting a Fresh Integer while parsing-  , freshIntP--  -- * Parsing Function-  , doParse'-  , parseFromFile-  , remainderP--  -- * Utilities-  , isSmall-  , isNotReserved--  , initPState, PState (..)--  , Fixity(..), Assoc(..), addOperatorP--  -- * For testing-  , expr0P-  , dataFieldP-  , dataCtorP-  , dataDeclP--  ) where--import qualified Data.HashMap.Strict         as M-import qualified Data.HashSet                as S-import qualified Data.Text                   as T-import           Data.Maybe                  (fromJust, fromMaybe)-import           Text.Parsec       hiding (State)-import           Text.Parsec.Expr-import qualified Text.Parsec.Token           as Token--- import           Text.Printf                 (printf)-import           GHC.Generics                (Generic)--import qualified Data.Char                   as Char -- (isUpper, isLower)-import           Language.Fixpoint.Smt.Bitvector-import           Language.Fixpoint.Types.Errors-import qualified Language.Fixpoint.Misc      as Misc      -import           Language.Fixpoint.Smt.Types--- import           Language.Fixpoint.Types.Visitor   (foldSort, mapSort)-import           Language.Fixpoint.Types hiding    (mapSort)-import           Text.PrettyPrint.HughesPJ         (text, nest, vcat, (<+>))--import Control.Monad.State--type Parser = ParsecT String Integer (State PState)-type ParserT u a = ParsecT String u (State PState) a--data PState = PState { fixityTable :: OpTable-                     , fixityOps   :: [Fixity]-                     , empList     :: Maybe Expr-                     , singList    :: Maybe (Expr -> Expr)}--------------------------------------------------------------------------emptyDef :: Monad m => Token.GenLanguageDef String a m-emptyDef    = Token.LanguageDef-               { Token.commentStart   = ""-               , Token.commentEnd     = ""-               , Token.commentLine    = ""-               , Token.nestedComments = True-               , Token.identStart     = lower <|> char '_'             -- letter <|> char '_'-               , Token.identLetter    = satisfy (`S.member` symChars)  -- alphaNum <|> oneOf "_"-               , Token.opStart        = Token.opLetter emptyDef-               , Token.opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~'"-               , Token.reservedOpNames= []-               , Token.reservedNames  = []-               , Token.caseSensitive  = True-               }--languageDef :: Monad m => Token.GenLanguageDef String a m-languageDef =-  emptyDef { Token.commentStart    = "/* "-           , Token.commentEnd      = " */"-           , Token.commentLine     = "//"-           , Token.identStart      = lower <|> char '_'-           , Token.identLetter     = alphaNum <|> oneOf "_"-           , Token.reservedNames   = S.toList reservedNames-           , Token.reservedOpNames =          reservedOpNames-           }--reservedNames :: S.HashSet String-reservedNames = S.fromList-  [ -- reserved words used in fixpoint-    "SAT"-  , "UNSAT"-  , "true"-  , "false"-  , "mod"-  , "data"-  , "Bexp"-  -- , "True"-  -- , "Int"-  , "import"-  , "if", "then", "else"-  , "func"-  , "autorewrite"-  , "rewrite"--  -- reserved words used in liquid haskell-  , "forall"-  , "coerce"-  , "exists"-  , "module"-  , "spec"-  , "where"-  , "decrease"-  , "lazyvar"-  , "LIQUID"-  , "lazy"-  , "local"-  , "assert"-  , "assume"-  , "automatic-instances"-  , "autosize"-  , "axiomatize"-  , "bound"-  , "class"-  , "data"-  , "define"-  , "defined"-  , "embed"-  , "expression"-  , "import"-  , "include"-  , "infix"-  , "infixl"-  , "infixr"-  , "inline"-  , "instance"-  , "invariant"-  , "measure"-  , "newtype"-  , "predicate"-  , "qualif"-  , "reflect"-  , "type"-  , "using"-  , "with"-  , "in"-  ]--reservedOpNames :: [String]-reservedOpNames =-  [ "+", "-", "*", "/", "\\", ":"-  , "<", ">", "<=", ">=", "=", "!=" , "/="-  , "mod", "and", "or"-  --, "is"-  , "&&", "||"-  , "~", "=>", "==>", "<=>"-  , "->"-  , ":="-  , "&", "^", "<<", ">>", "--"-  , "?", "Bexp"-  , "'"-  , "_|_"-  , "|"-  , "<:"-  , "|-"-  , "::"-  , "."-  ]--lexer :: Monad m => Token.GenTokenParser String u m-lexer = Token.makeTokenParser languageDef---reserved :: String -> Parser ()-reserved      = Token.reserved      lexer--reservedOp :: String -> Parser ()-reservedOp    = Token.reservedOp    lexer--parens, brackets, angles, braces :: ParserT u a -> ParserT u a-parens        = Token.parens        lexer-brackets      = Token.brackets      lexer-angles        = Token.angles        lexer-braces        = Token.braces        lexer--sbraces :: Parser a -> Parser a -sbraces pp   = braces $ (spaces *> pp <* spaces)--semi, colon, comma, dot, stringLiteral :: Parser String-semi          = Token.semi          lexer-colon         = Token.colon         lexer-comma         = Token.comma         lexer-dot           = Token.dot           lexer-stringLiteral = Token.stringLiteral lexer--whiteSpace :: Parser ()-whiteSpace    = Token.whiteSpace    lexer--double :: Parser Double-double        = Token.float         lexer--- integer       = Token.integer       lexer---- identifier :: Parser String--- identifier = Token.identifier lexer---- TODO:AZ: pretty sure there is already a whitespace eater in parsec,-blanks :: Parser String-blanks  = many (satisfy (`elem` [' ', '\t']))---- | Integer-integer :: Parser Integer-integer = Token.natural lexer <* spaces----  try (char '-' >> (negate <$> posInteger))---       <|> posInteger--- posInteger :: Parser Integer--- posInteger = toI <$> (many1 digit <* spaces)---  where---    toI :: String -> Integer---    toI = read-------------------------------------------------------------------------------------------- Expressions ---------------------------------------------------------------------------------------------locParserP :: Parser a -> Parser (Located a)-locParserP p = do l1 <- getPosition-                  x  <- p-                  l2 <- getPosition-                  return $ Loc l1 l2 x----- FIXME: we (LH) rely on this parser being dumb and *not* consuming trailing--- whitespace, in order to avoid some parsers spanning multiple lines..--condIdP  :: Parser Char -> S.HashSet Char -> (String -> Bool) -> Parser Symbol-condIdP initP okChars p-  = do c    <- initP -       cs   <- many (satisfy (`S.member` okChars))-       blanks-       let s = c:cs-       if p s then return (symbol s) else parserZero---- upperIdP :: Parser Symbol--- upperIdP = do---  c  <- upper---  cs <- many (satisfy (`S.member` symChars))---  blanks---  return (symbol $ c:cs)--- lowerIdP = do-  -- c  <- satisfy (\c -> isLower c || c == '_' )-  -- cs <- many (satisfy (`S.member` symChars))-  -- blanks-  -- return (symbol $ c:cs)---- TODO:RJ we really _should_ just use the below, but we cannot,--- because 'identifier' also chomps newlines which then make--- it hard to parse stuff like: "measure foo :: a -> b \n foo x = y"--- as the type parser thinks 'b \n foo` is a type. Sigh.--- lowerIdP :: Parser Symbol--- lowerIdP = symbol <$> (identifier <* blanks)--upperIdP :: Parser Symbol-upperIdP  = condIdP upper                  symChars (const True)--lowerIdP :: Parser Symbol-lowerIdP  = condIdP (lower <|> char '_')   symChars isNotReserved--symCharsP :: Parser Symbol-symCharsP = condIdP (letter <|> char '_')  symChars isNotReserved--isNotReserved :: String -> Bool-isNotReserved s = not (s `S.member` reservedNames)---- (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool--- f &&& g = \x -> f x && g x--- | String Haskell infix Id-infixIdP :: Parser String-infixIdP = many (satisfy (`notElem` [' ', '.']))--isSmall :: Char -> Bool-isSmall c = Char.isLower c || c == '_'--locSymbolP, locLowerIdP, locUpperIdP :: Parser LocSymbol-locLowerIdP = locParserP lowerIdP-locUpperIdP = locParserP upperIdP-locSymbolP  = locParserP symbolP---- | Arbitrary Symbols-symbolP :: Parser Symbol-symbolP = symbol <$> symCharsP---- | (Integer) Constants-constantP :: Parser Constant-constantP =  try (R <$> double)-         <|> I <$> integer---symconstP :: Parser SymConst-symconstP = SL . T.pack <$> stringLiteral--expr0P :: Parser Expr-expr0P-  =  trueP- <|> falseP- <|> fastIfP EIte exprP- <|> coerceP exprP- <|> (ESym <$> symconstP)- <|> (ECon <$> constantP)- <|> (reservedOp "_|_" >> return EBot)- <|> lamP- <|> try tupleP-  -- TODO:AZ get rid of these try, after the rest- <|> try (parens exprP)- <|> (reserved "[]" >> emptyListP)- <|> try (brackets exprP >>= singletonListP) - <|> try (parens exprCastP)- <|> (charsExpr <$> symCharsP)--emptyListP :: Parser Expr-emptyListP = do -  e <- empList <$> get -  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-  case f of -    Nothing -> fail "No parsing support for singleton lists"-    Just s  -> return $ s e --exprCastP :: Parser Expr-exprCastP-  = do e  <- exprP-       (try dcolon) <|> colon-       so <- sortP-       return $ ECst e so--charsExpr :: Symbol -> Expr-charsExpr cs-  | isSmall (headSym cs) = expr cs-  | otherwise            = EVar cs--fastIfP :: (Expr -> a -> a -> a) -> Parser a -> Parser a-fastIfP f bodyP-  = do reserved "if"-       p <- predP-       reserved "then"-       b1 <- bodyP-       reserved "else"-       b2 <- bodyP-       return $ f p b1 b2--coerceP :: Parser Expr -> Parser Expr-coerceP p = do-  reserved "coerce"-  (s, t) <- parens (pairP sortP (reservedOp "~") sortP)-  e      <- p-  return $ ECoerc s t e----{--qmIfP f bodyP-  = parens $ do-      p  <- predP-      reserved "?"-      b1 <- bodyP-      colon-      b2 <- bodyP-      return $ f p b1 b2--}---- | Used as input to @Text.Parsec.Expr.buildExpressionParser@ to create @exprP@-expr1P :: Parser Expr-expr1P-  =  try funAppP- <|> expr0P---- | Expressions-exprP :: Parser Expr-exprP = (fixityTable <$> get) >>= (`buildExpressionParser` expr1P)--data Fixity-  = FInfix   {fpred :: Maybe Int, fname :: String, fop2 :: Maybe (Expr -> Expr -> Expr), fassoc :: Assoc}-  | FPrefix  {fpred :: Maybe Int, fname :: String, fop1 :: Maybe (Expr -> Expr)}-  | FPostfix {fpred :: Maybe Int, fname :: String, fop1 :: Maybe (Expr -> Expr)}----- Invariant : OpTable has 10 elements-type OpTable = OperatorTable String Integer (State PState) Expr--addOperatorP :: Fixity -> Parser ()-addOperatorP op-  = modify $ \s -> s{ fixityTable =  addOperator op (fixityTable s)-                    , fixityOps   =  op:fixityOps s -                    }--infixSymbolP :: Parser Symbol-infixSymbolP = do -  ops <- infixOps <$> get -  choice (reserved' <$> ops)-  where -    infixOps st = [s | FInfix _ s _ _ <- fixityOps st]-    reserved' x = reserved x >> return (symbol x) --addOperator :: Fixity -> OpTable -> OpTable-addOperator (FInfix p x f assoc) ops- = insertOperator (makePrec p) (Infix (reservedOp x >> return (makeInfixFun x f)) assoc) ops-addOperator (FPrefix p x f) ops- = insertOperator (makePrec p) (Prefix (reservedOp x >> return (makePrefixFun x f))) ops-addOperator (FPostfix p x f) ops- = insertOperator (makePrec p) (Postfix (reservedOp x >> return (makePrefixFun x f))) ops--makePrec :: Maybe Int -> Int-makePrec = fromMaybe 9--makeInfixFun :: String -> Maybe (Expr -> Expr -> Expr) -> Expr -> Expr -> Expr-makeInfixFun x = fromMaybe (\e1 e2 -> EApp (EApp (EVar $ symbol x) e1) e2)--makePrefixFun :: String -> Maybe (Expr -> Expr) -> Expr -> Expr-makePrefixFun x = fromMaybe (EApp (EVar $ symbol x))--insertOperator :: Int -> Operator String Integer (State PState) Expr -> OpTable -> OpTable-insertOperator i op = go (9 - i) -  where-    go _ []         = die $ err dummySpan (text "insertOperator on empty ops")-    go 0 (xs:xss)   = (xs ++ [op]) : xss-    go i (xs:xss)   = xs : go (i - 1) xss--initOpTable :: OpTable-initOpTable = replicate 10 [] --bops :: Maybe Expr -> OpTable-bops cmpFun = foldl (flip addOperator) initOpTable buildinOps-  where--- Build in Haskell ops https://www.haskell.org/onlinereport/decls.html#fixity-    buildinOps = [ FPrefix (Just 9) "-"   (Just ENeg)-                 , FInfix  (Just 7) "*"   (Just $ EBin Times) AssocLeft-                 , FInfix  (Just 7) "/"   (Just $ EBin Div)   AssocLeft-                 , FInfix  (Just 6) "-"   (Just $ EBin Minus) AssocLeft-                 , FInfix  (Just 6) "+"   (Just $ EBin Plus)  AssocLeft-                 , FInfix  (Just 5) "mod" (Just $ EBin Mod)   AssocLeft -- Haskell gives mod 7-                 , FInfix  (Just 9) "."   applyCompose        AssocRight-                 ]-    applyCompose = (\f x y -> (f `eApps` [x,y])) <$> cmpFun---- | Function Applications-funAppP :: Parser Expr-funAppP            =  litP <|> exprFunP <|> simpleAppP-  where-    exprFunP = mkEApp <$> funSymbolP <*> funRhsP-    funRhsP  =  sepBy1 expr0P blanks-            <|> parens innerP-    innerP   = brackets (sepBy exprP semi)--    -- TODO:AZ the parens here should be superfluous, but it hits an infinite loop if removed-    simpleAppP     = EApp <$> parens exprP <*> parens exprP-    funSymbolP     = locParserP symbolP---tupleP :: Parser Expr-tupleP = do-  let tp = parens (pairP exprP comma (sepBy1 exprP comma))-  Loc l1 l2 (first, rest) <- locParserP tp-  let cons = symbol $ "(" ++ replicate (length rest) ',' ++ ")"-  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))-litP :: Parser Expr-litP = do reserved "lit"-          l <- stringLiteral-          t <- sortP-          return $ ECon $ L (T.pack l) t---- parenBrackets :: Parser a -> Parser a--- parenBrackets  = parens . brackets---- eMinus     = EBin Minus (expr (0 :: Integer))--- eCons x xs = EApp (dummyLoc consName) [x, xs]--- eNil       = EVar nilName--lamP :: Parser Expr-lamP-  = do reservedOp "\\"-       x <- symbolP-       colon-       t <- sortP-       reservedOp "->"-       e  <- exprP-       return $ ELam (x, t) e--dcolon :: Parser String-dcolon = string "::" <* spaces--varSortP :: Parser Sort-varSortP  = FVar  <$> parens intP--funcSortP :: Parser Sort-funcSortP = parens $ mkFFunc <$> intP <* comma <*> sortsP--sortsP :: Parser [Sort]-sortsP = brackets $ sepBy sortP semi---- | Sort-sortP    :: Parser Sort-sortP    = sortP' (sepBy sortArgP blanks)--sortArgP :: Parser Sort-sortArgP = sortP' (return [])--{--sortFunP :: Parser Sort-sortFunP-   =  try (string "@" >> varSortP)-  <|> (fTyconSort <$> fTyConP)--}--sortP' :: Parser [Sort] -> Parser Sort-sortP' appArgsP-   =  parens sortP-  <|> (reserved "func" >> funcSortP)-  <|> (fAppTC listFTyCon . single <$> brackets sortP)-  <|> bvSortP-  <|> (fAppTC <$> fTyConP <*> appArgsP)-  <|> (fApp   <$> tvarP   <*> appArgsP)--single :: a -> [a]-single x = [x]--tvarP :: Parser Sort-tvarP-   =  (string "@" >> varSortP)-  <|> (FObj . symbol <$> lowerIdP)---fTyConP :: Parser FTycon-fTyConP-  =   (reserved "int"     >> return intFTyCon)-  <|> (reserved "Integer" >> return intFTyCon)-  <|> (reserved "Int"     >> return intFTyCon)-  -- <|> (reserved "int"     >> return intFTyCon) -- TODO:AZ duplicate?-  <|> (reserved "real"    >> return realFTyCon)-  <|> (reserved "bool"    >> return boolFTyCon)-  <|> (reserved "num"     >> return numFTyCon)-  <|> (reserved "Str"     >> return strFTyCon)-  <|> (symbolFTycon      <$> locUpperIdP)---- | Bit-Vector Sort-bvSortP :: Parser Sort-bvSortP = mkSort <$> (bvSizeP "Size32" S32 <|> bvSizeP "Size64" S64)-  where-    bvSizeP ss s = do-      parens (reserved "BitVec" >> reserved ss)-      return s-------------------------------------------------------------------------------------- | Predicates ---------------------------------------------------------------------------------------------------------------------------------------------------pred0P :: Parser Expr-pred0P =  trueP-      <|> falseP-      <|> (reservedOp "??" >> makeUniquePGrad)-      <|> kvarPredP-      <|> (fastIfP pIte predP)-      <|> try predrP-      <|> (parens predP)-      <|> (reservedOp "?" *> exprP)-      <|> try funAppP-      <|> (eVar <$> symbolP)-      <|> (reservedOp "&&" >> pGAnds <$> predsP)-      <|> (reservedOp "||" >> POr  <$> predsP)--makeUniquePGrad :: Parser Expr-makeUniquePGrad-  = do uniquePos <- getPosition-       return $ PGrad (KV $ symbol $ show uniquePos) mempty (srcGradInfo uniquePos) mempty---- qmP    = reserved "?" <|> reserved "Bexp"--trueP, falseP :: Parser Expr-trueP  = reserved "true"  >> return PTrue-falseP = reserved "false" >> return PFalse--kvarPredP :: Parser Expr-kvarPredP = PKVar <$> kvarP <*> substP--kvarP :: Parser KVar-kvarP = KV <$> (char '$' *> symbolP <* spaces)--substP :: Parser Subst-substP = mkSubst <$> many (brackets $ pairP symbolP aP exprP)-  where-    aP = reservedOp ":="--predsP :: Parser [Expr]-predsP = brackets $ sepBy predP semi--predP  :: Parser Expr-predP  = buildExpressionParser lops pred0P-  where-    lops = [ [Prefix (reservedOp "~"    >> return PNot)]-           , [Prefix (reservedOp "not " >> return PNot)]-           , [Infix  (reservedOp "&&"   >> return pGAnd) AssocRight]-           , [Infix  (reservedOp "||"   >> return (\x y -> POr  [x,y])) AssocRight]-           , [Infix  (reservedOp "=>"   >> return PImp) AssocRight]-           , [Infix  (reservedOp "==>"  >> return PImp) AssocRight]-           , [Infix  (reservedOp "<=>"  >> return PIff) AssocRight]]--predrP :: Parser Expr-predrP = do e1    <- exprP-            r     <- brelP-            e2    <- exprP-            return $ r e1 e2--brelP ::  Parser (Expr -> Expr -> Expr)-brelP =  (reservedOp "==" >> return (PAtom Eq))-     <|> (reservedOp "="  >> return (PAtom Eq))-     <|> (reservedOp "~~" >> return (PAtom Ueq))-     <|> (reservedOp "!=" >> return (PAtom Ne))-     <|> (reservedOp "/=" >> return (PAtom Ne))-     <|> (reservedOp "!~" >> return (PAtom Une))-     <|> (reservedOp "<"  >> return (PAtom Lt))-     <|> (reservedOp "<=" >> return (PAtom Le))-     <|> (reservedOp ">"  >> return (PAtom Gt))-     <|> (reservedOp ">=" >> return (PAtom Ge))------------------------------------------------------------------------------------- | BareTypes ------------------------------------------------------------------------------------------------------------------------------------------------------ | Refa-refaP :: Parser Expr-refaP =  try (pAnd <$> brackets (sepBy predP semi))-     <|> predP----- | (Sorted) Refinements with configurable sub-parsers-refBindP :: Parser Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a-refBindP bp rp kindP-  = braces $ do-      x  <- bp-      t  <- kindP-      reservedOp "|"-      ra <- rp <* spaces-      return $ t (Reft (x, ra))----- bindP      = symbol    <$> (lowerIdP <* colon)--- | Binder (lowerIdP <* colon)-bindP :: Parser Symbol-bindP = symbolP <* colon--optBindP :: Symbol -> Parser Symbol-optBindP x = try bindP <|> return x---- | (Sorted) Refinements-refP :: Parser (Reft -> a) -> Parser a-refP       = refBindP bindP refaP---- | (Sorted) Refinements with default binder-refDefP :: Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a-refDefP x  = refBindP (optBindP x)------------------------------------------------------------------------------------- | Parsing Data Declarations ------------------------------------------------------------------------------------------------------------------------------------dataFieldP :: Parser DataField-dataFieldP = DField <$> locSymbolP <* colon <*> sortP--dataCtorP :: Parser DataCtor-dataCtorP  = DCtor <$> locSymbolP-                   <*> braces (sepBy dataFieldP comma)--dataDeclP :: Parser DataDecl-dataDeclP  = DDecl <$> fTyConP <*> intP <* reservedOp "="-                   <*> brackets (many (reservedOp "|" *> dataCtorP))------------------------------------------------------------------------------------- | Parsing Qualifiers --------------------------------------------------------------------------------------------------------------------------------------------- | Qualifiers-qualifierP :: Parser Sort -> Parser Qualifier-qualifierP tP = do-  pos    <- getPosition-  n      <- upperIdP-  params <- parens $ sepBy1 (qualParamP tP) comma-  _      <- colon-  body   <- predP-  return  $ mkQual n params body pos--qualParamP :: Parser Sort -> Parser QualParam -qualParamP tP = do -  x     <- symbolP -  pat   <- qualPatP -  _     <- colon -  t     <- tP -  return $ QP x pat t --qualPatP :: Parser QualPattern-qualPatP -   =  (reserved "as" >> qualStrPatP)-  <|> return PatNone --qualStrPatP :: Parser QualPattern-qualStrPatP -   = (PatExact <$> symbolP)-  <|> parens (    (uncurry PatPrefix <$> pairP symbolP dot qpVarP)-              <|> (uncurry PatSuffix <$> pairP qpVarP  dot symbolP) )---qpVarP :: Parser Int-qpVarP = char '$' *> intP --symBindP :: Parser a -> Parser (Symbol, a)-symBindP = pairP symbolP colon--pairP :: Parser a -> Parser z -> Parser b -> Parser (a, b)-pairP xP sepP yP = (,) <$> xP <* sepP <*> yP-------------------------------------------------------------------------- | Axioms for Symbolic Evaluation ---------------------------------------------------------------------------------------------------------autoRewriteP :: Parser AutoRewrite-autoRewriteP = do-  args       <- sepBy sortedReftP spaces-  _          <- spaces-  _          <- reserved "="-  _          <- spaces-  (lhs, rhs) <- braces $-      pairP exprP (reserved "=") exprP-  return $ AutoRewrite args lhs rhs---defineP :: Parser Equation-defineP = do-  name   <- symbolP-  params <- parens        $ sepBy (symBindP sortP) comma-  sort   <- colon        *> sortP-  body   <- reserved "=" *> sbraces (-              if sort == boolSort then predP else exprP-               )-  return  $ mkEquation name params body sort--matchP :: Parser Rewrite-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------------------------------------------------------------------------- | Parsing Constraints (.fq files) ---------------------------------------------------------------------------------------------------------- Entities in Query File-data Def a-  = Srt !Sort-  | Cst !(SubC a)-  | Wfc !(WfC a)-  | Con !Symbol !Sort-  | Dis !Symbol !Sort-  | Qul !Qualifier-  | Kut !KVar-  | Pack !KVar !Int-  | IBind !Int !Symbol !SortedReft-  | EBind !Int !Symbol !Sort -  | Opt !String-  | Def !Equation-  | Mat !Rewrite-  | Expand ![(Int,Bool)]-  | Adt  !DataDecl-  | AutoRW !Int !AutoRewrite-  | RWMap ![(Int,Int)]-  deriving (Show, Generic)-  --  Sol of solbind-  --  Dep of FixConstraint.dep--fInfoOptP :: Parser (FInfoWithOpts ())-fInfoOptP = do ps <- many defP-               return $ FIO (defsFInfo ps) [s | Opt s <- ps]--fInfoP :: Parser (FInfo ())-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)-    <|> 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)-    <|> Opt    <$> (reserved "fixpoint"    >> stringLiteral)-    <|> Def    <$> (reserved "define"      >> defineP)-    <|> Mat    <$> (reserved "match"       >> matchP)-    <|> Expand <$> (reserved "expand"      >> pairsP intP boolP)-    <|> Adt    <$> (reserved "data"        >> dataDeclP)-    <|> AutoRW <$> (reserved "autorewrite" >> intP) <*> autoRewriteP-    <|> RWMap  <$> (reserved "rewrite"     >> pairsP intP intP)---sortedReftP :: Parser SortedReft-sortedReftP = refP (RR <$> (sortP <* spaces))--wfCP :: Parser (WfC ())-wfCP = do reserved "env"-          env <- envP-          reserved "reft"-          r   <- sortedReftP-          let [w] = wfC env r ()-          return w--subCP :: Parser (SubC ())-subCP = do pos <- getPosition-           reserved "env"-           env <- envP-           reserved "lhs"-           lhs <- sortedReftP-           reserved "rhs"-           rhs <- sortedReftP-           reserved "id"-           i   <- integer <* spaces-           tag <- tagP-           pos' <- getPosition-           return $ subC' env lhs rhs i tag pos pos'--subC' :: IBindEnv-      -> SortedReft-      -> SortedReft-      -> Integer-      -> Tag-      -> SourcePos-      -> SourcePos-      -> SubC ()-subC' env lhs rhs i tag l l'-  = case cs of-      [c] -> c-      _   -> die $ err sp $ "RHS without single conjunct at" <+> pprint l'-    where-       cs = subC env lhs rhs (Just i) tag ()-       sp = SS l l'---tagP  :: Parser [Int]-tagP  = reserved "tag" >> spaces >> brackets (sepBy intP semi)--envP  :: Parser IBindEnv-envP  = do binds <- brackets $ sepBy (intP <* spaces) semi-           return $ insertsIBindEnv binds emptyIBindEnv--intP :: Parser Int-intP = fromInteger <$> integer--boolP :: Parser Bool-boolP = (reserved "True" >> return True)-    <|> (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-  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]-    lts        = fromListSEnv       [(x, t)             | Con x t     <- defs]-    dts        = fromListSEnv       [(x, t)             | Dis x t     <- defs]-    kts        = KS $ S.fromList    [k                  | Kut k       <- defs]-    qs         =                    [q                  | Qul q       <- defs]-    binfo      = mempty-    expand     = M.fromList         [(fromIntegral i, f)| Expand fs   <- defs, (i,f) <- fs]-    eqs        =                    [e                  | Def e       <- defs]-    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-                 where-                   insert map (cid, arId) =-                     case M.lookup arId autoRWs of-                       Just rewrite ->-                         M.insertWith (++) (fromIntegral cid) [rewrite] map-                       Nothing ->-                         map-    cid        = fromJust . sid-    ae         = AEnv eqs rews expand rwMap-    adts       =                    [d                  | Adt d       <- defs]-    -- msg    = show $ "#Lits = " ++ (show $ length consts)-------------------------------------------------------------------------- | Interacting with Fixpoint --------------------------------------------------------------------------------------------------------------fixResultP :: Parser a -> Parser (FixResult a)-fixResultP pp-  =  (reserved "SAT"   >> return (Safe mempty))- <|> (reserved "UNSAT" >> Unsafe mempty <$> brackets (sepBy pp comma))- <|> (reserved "CRASH" >> crashP pp)--crashP :: Parser a -> Parser (FixResult a)-crashP pp = do-  i   <- pp-  msg <- many anyChar-  return $ Crash [i] msg--predSolP :: Parser Expr-predSolP = parens (predP  <* (comma >> iQualP))--iQualP :: Parser [Symbol]-iQualP = upperIdP >> parens (sepBy symbolP comma)--solution1P :: Parser (KVar, Expr)-solution1P = do-  reserved "solution:"-  k  <- kvP-  reservedOp ":="-  ps <- brackets $ sepBy predSolP semi-  return (k, simplify $ PAnd ps)-  where-    kvP = try kvarP <|> (KV <$> symbolP)--solutionP :: Parser (M.HashMap KVar Expr)-solutionP = M.fromList <$> sepBy solution1P whiteSpace--solutionFileP :: Parser (FixResult Integer, M.HashMap KVar Expr)-solutionFileP = (,) <$> fixResultP integer <*> solutionP-----------------------------------------------------------------------------------remainderP :: Parser a -> Parser (a, String, SourcePos)-remainderP p-  = do res <- p-       str <- getInput-       pos <- getPosition-       return (res, str, pos)---initPState :: Maybe Expr -> PState-initPState cmpFun = PState { fixityTable = bops cmpFun-                           , empList     = Nothing-                           , singList    = Nothing-                           , fixityOps   = [] -                           }--doParse' :: Parser a -> SourceName -> String -> a-doParse' parser f s-  = case evalState (runParserT (remainderP (whiteSpace >> parser)) 0 f s) $ initPState Nothing of-      Left e            -> die $ err (errorSpan e) (dErr e)-      Right (r, "", _)  -> r-      Right (_, r, l)   -> die $ err (SS l l) (dRem r)-    where-      dErr e = vcat [ "parseError"        <+> Misc.tshow e-                    , "when parsing from" <+> text f ]-      dRem r = vcat [ "doParse has leftover"-                    , nest 4 (text r)-                    , "when parsing from" <+> text f ]---errorSpan :: ParseError -> SrcSpan-errorSpan e = SS l l where l = errorPos e--parseFromFile :: Parser b -> SourceName -> IO b-parseFromFile p f = doParse' p f <$> readFile f--freshIntP :: Parser Integer-freshIntP = do n <- getState-               updateState (+ 1)-               return n-------------------------------------------------------------------------- Standalone SMTLIB2 commands -------------------------------------------------------------------------------------------------------------commandsP :: Parser [Command]-commandsP = sepBy commandP semi--commandP :: Parser Command-commandP-  =  (reserved "var"      >> cmdVarP)- <|> (reserved "push"     >> return Push)- <|> (reserved "pop"      >> return Pop)- <|> (reserved "check"    >> return CheckSat)- <|> (reserved "assert"   >> (Assert Nothing <$> predP))- <|> (reserved "distinct" >> (Distinct <$> brackets (sepBy exprP comma)))--cmdVarP :: Parser Command-cmdVarP = error "UNIMPLEMENTED: cmdVarP"--- do-  -- x <- bindP-  -- t <- sortP-  -- return $ Declare x [] t-------------------------------------------------------------------------- Bundling Parsers into a Typeclass --------------------------------------------------------------------------------------------------------class Inputable a where-  rr  :: String -> a-  rr' :: String -> String -> a-  rr' _ = rr-  rr    = rr' ""--instance Inputable Symbol where-  rr' = doParse' symbolP--instance Inputable Constant where-  rr' = doParse' constantP--instance Inputable Expr where-  rr' = doParse' exprP--instance Inputable (FixResult Integer) where-  rr' = doParse' $ fixResultP integer--instance Inputable (FixResult Integer, FixSolution) where-  rr' = doParse' solutionFileP--instance Inputable (FInfo ()) where-  rr' = {-# SCC "fInfoP" #-} doParse' fInfoP--instance Inputable (FInfoWithOpts ()) where-  rr' = {-# SCC "fInfoWithOptsP" #-} doParse' fInfoOptP+  -- * Some Important keyword and parsers+  , reserved, reservedOp+  , locReserved+  , parens  , brackets, angles, braces+  , semi    , comma+  , colon   , dcolon+  , dot+  , pairP+  , stringLiteral+  , locStringLiteral++  -- * Parsing basic entities++  --   fTyConP  -- Type constructors+  , lowerIdP    -- Lower-case identifiers+  , upperIdP    -- Upper-case identifiers+  -- , infixIdP    -- String Haskell infix Id+  , symbolP     -- Arbitrary Symbols+  , locSymbolP+  , constantP   -- (Integer) Constants+  , natural     -- Non-negative integer+  , locNatural+  , bindP       -- Binder (lowerIdP <* colon)+  , sortP       -- Sort+  , mkQual      -- constructing qualifiers+  , infixSymbolP -- parse infix symbols+  , locInfixSymbolP++  -- * Parsing recursive entities+  , exprP       -- Expressions+  , predP       -- Refinement Predicates+  , funAppP     -- Function Applications+  , qualifierP  -- Qualifiers+  , refaP       -- Refa+  , refP        -- (Sorted) Refinements+  , refDefP     -- (Sorted) Refinements with default binder+  , refBindP    -- (Sorted) Refinements with configurable sub-parsers+  , bvSortP     -- Bit-Vector Sort+  , defineP     -- function definition equations (PLE)+  , matchP      -- measure definition equations (PLE)++  -- * Layout+  , indentedBlock+  , indentedLine+  , indentedOrExplicitBlock+  , explicitBlock+  , explicitCommaBlock+  , block+  , spaces+  , setLayout+  , popLayout++  -- * Raw identifiers+  , condIdR++  -- * Lexemes and lexemes with location+  , lexeme+  , located+  , locLexeme+  , locLowerIdP+  , locUpperIdP++  -- * Getting a Fresh Integer while parsing+  , freshIntP++  -- * Parsing Function+  , doParse'+  , parseTest'+  , parseFromFile+  , parseFromStdIn+  , remainderP++  -- * Utilities+  , isSmall+  , isNotReserved++  , initPState, PState (..)++  , LayoutStack(..)+  , Fixity(..), Assoc(..), addOperatorP++  -- * For testing+  , expr0P+  , dataFieldP+  , dataCtorP+  , dataDeclP++  ) where++import           Control.Monad.Combinators.Expr+import qualified Data.IntMap.Strict          as IM+import qualified Data.HashMap.Strict         as M+import qualified Data.HashSet                as S+import           Data.List                   (foldl')+import           Data.List.NonEmpty          (NonEmpty(..))+import qualified Data.Text                   as T+import qualified Data.Text.IO                as T+import           Data.Maybe                  (fromJust, fromMaybe)+import           Data.Void+import           Text.Megaparsec             hiding (State, ParseError)+import           Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer  as L+import           GHC.Generics                (Generic)++import qualified Data.Char                   as Char+import           Language.Fixpoint.Smt.Bitvector+import           Language.Fixpoint.Types.Errors+import qualified Language.Fixpoint.Misc      as Misc+import           Language.Fixpoint.Smt.Types+import           Language.Fixpoint.Types hiding    (mapSort)+import           Text.PrettyPrint.HughesPJ         (text, vcat, (<+>), Doc)++import Control.Monad.State++-- import Debug.Trace++-- Note [Parser monad]+--+-- For reference,+--+-- in *parsec*, the base monad transformer is+--+-- ParsecT s u m a+--+-- where+--+--   s   is the input stream type+--   u   is the user state type+--   m   is the underlying monad+--   a   is the return type+--+-- whereas in *megaparsec*, the base monad transformer is+--+-- ParsecT e s m a+--+-- where+--+--   e   is the custom data component for errors+--   s   is the input stream type+--   m   is the underlying monad+--   a   is the return type+--+-- The Liquid Haskell parser tracks state in 'PState', primarily+-- for operator fixities.+--+-- The old Liquid Haskell parser did not use parsec's "user state"+-- functionality for 'PState', but instead wrapped a state monad+-- in a parsec monad. We do the same thing for megaparsec.+--+-- However, user state was still used for an additional 'Integer'+-- as a unique supply. We incorporate this in the 'PState'.+--+-- Furthermore, we have to decide whether the state in the parser+-- should be "backtracking" or not. "Backtracking" state resets when+-- the parser backtracks, and thus only contains state modifications+-- performed by successful parses. On the other hand, non-backtracking+-- state would contain all modifications made during the parsing+-- process and allow us to observe unsuccessful attempts.+--+-- It turns out that:+--+-- - parsec's old built-in user state is backtracking+-- - using @StateT s (ParsecT ...)@ is backtracking+-- - using @ParsecT ... (StateT s ...)@ is non-backtracking+--+-- We want all our state to be backtracking.+--+-- Note that this is in deviation from what the old LH parser did,+-- but I think that was plainly wrong.++type Parser = StateT PState (Parsec Void String)++-- | The parser state.+--+-- We keep track of the fixities of infix operators.+--+-- We also keep track of whether empty list and singleton lists+-- syntax is allowed (and how they are to be interpreted, if they+-- are).+--+-- We also keep track of an integer counter that can be used to+-- supply unique integers during the parsing process.+--+-- Finally, we keep track of the layout stack.+--+data PState = PState { fixityTable :: OpTable+                     , fixityOps   :: [Fixity]+                     , empList     :: Maybe Expr+                     , singList    :: Maybe (Expr -> Expr)+                     , supply      :: !Integer+                     , layoutStack :: LayoutStack+                     }++-- | The layout stack tracks columns at which layout blocks+-- have started.+--+data LayoutStack =+    Empty -- ^ no layout info+  | Reset LayoutStack -- ^ in a block not using layout+  | At Pos LayoutStack -- ^ in a block at the given column+  | After Pos LayoutStack -- ^ past a block at the given column+  deriving Show++-- | Pop the topmost element from the stack.+popLayoutStack :: LayoutStack -> LayoutStack+popLayoutStack Empty       = error "unbalanced layout stack"+popLayoutStack (Reset s)   = s+popLayoutStack (At _ s)    = s+popLayoutStack (After _ s) = s++-- | Modify the layout stack using the given function.+modifyLayoutStack :: (LayoutStack -> LayoutStack) -> Parser ()+modifyLayoutStack f =+  modify (\ s -> s { layoutStack = f (layoutStack s) })++-- | Start a new layout block at the current indentation level.+setLayout :: Parser ()+setLayout = do+  i <- L.indentLevel+  -- traceShow ("setLayout", i) $ pure ()+  modifyLayoutStack (At i)++-- | Temporarily reset the layout information, because we enter+-- a block with explicit separators.+--+resetLayout :: Parser ()+resetLayout = do+  -- traceShow ("resetLayout") $ pure ()+  modifyLayoutStack Reset++-- | Remove the topmost element from the layout stack.+popLayout :: Parser ()+popLayout = do+  -- traceShow ("popLayout") $ pure ()+  modifyLayoutStack popLayoutStack++-- | Consumes all whitespace, including LH comments.+--+-- Should not be used directly, but primarily via 'lexeme'.+--+-- The only "valid" use case for spaces is in top-level parsing+-- function, to consume initial spaces.+--+spaces :: Parser ()+spaces =+  L.space+    space1+    lhLineComment+    lhBlockComment++-- | Verify that the current indentation level is in the given+-- relation to the provided reference level, otherwise fail.+--+-- This is a variant of 'indentGuard' provided by megaparsec,+-- only that it does not consume whitespace.+--+guardIndentLevel :: Ordering -> Pos -> Parser ()+guardIndentLevel ord ref = do+  actual <- L.indentLevel+  -- traceShow ("guardIndentLevel", actual, ord, ref) $ pure ()+  unless (compare actual ref == ord)+    (L.incorrectIndent ord ref actual)++-- | Checks the current indentation level with respect to the+-- current layout stack. May fail. Returns the parser to run+-- after the next token.+--+-- This function is intended to be used within a layout block+-- to check whether the next token is valid within the current+-- block.+--+guardLayout :: Parser (Parser ())+guardLayout = do+  stack <- gets layoutStack+  -- traceShow ("guardLayout", stack) $ pure ()+  case stack of+    At i s    -> guardIndentLevel EQ i *> pure (modifyLayoutStack (const (After i (At i s))))+      -- Note: above, we must really set the stack to 'After i (At i s)' explicitly.+      -- Otherwise, repeated calls to 'guardLayout' at the same column could push+      -- multiple 'After' entries on the stack.+    After i _ -> guardIndentLevel GT i *> pure (pure ())+    _         -> pure (pure ())++-- | Checks the current indentation level with respect to the+-- current layout stack. The current indentation level must+-- be strictly greater than the one of the surrounding block.+-- May fail.+--+-- This function is intended to be used before we establish+-- a new, nested, layout block, which should be indented further+-- than the surrounding blocks.+--+strictGuardLayout :: Parser ()+strictGuardLayout = do+  stack <- gets layoutStack+  -- traceShow ("strictGuardLayout", stack) $ pure ()+  case stack of+    At i _    -> guardIndentLevel GT i *> pure ()+    After i _ -> guardIndentLevel GT i *> pure ()+    _         -> pure ()+++-- | Indentation-aware lexeme parser. Before parsing, establishes+-- whether we are in a position permitted by the layout stack.+-- After the token, consume whitespace and potentially change state.+--+lexeme :: Parser a -> Parser a+lexeme p = do+  after <- guardLayout+  p <* spaces <* after++-- | Indentation-aware located lexeme parser.+--+-- This is defined in such a way that it determines the actual source range+-- covered by the identifier. I.e., it consumes additional whitespace in the+-- end, but that is not part of the source range reported for the identifier.+--+locLexeme :: Parser a -> Parser (Located a)+locLexeme p = do+  after <- guardLayout+  l1 <- getSourcePos+  x <- p+  l2 <- getSourcePos+  spaces <* after+  pure (Loc l1 l2 x)++-- | Make a parser location-aware.+--+-- This is at the cost of an imprecise span because we still+-- consume spaces in the end first.+--+located :: Parser a -> Parser (Located a)+located p = do+  l1 <- getSourcePos+  x <- p+  l2 <- getSourcePos+  pure (Loc l1 l2 x)++-- | Parse a block delimited by layout.+-- The block must be indented more than the surrounding blocks,+-- otherwise we return an empty list.+--+-- Assumes that the parser for items does not accept the empty string.+--+indentedBlock :: Parser a -> Parser [a]+indentedBlock p =+      strictGuardLayout *> setLayout *> many (p <* popLayout) <* popLayout+      -- We have to pop after every p, because the first successful+      -- token moves from 'At' to 'After'. We have to pop at the end,+      -- because we want to remove 'At'.+  <|> pure []+      -- We need to have a fallback with the empty list, because if the+      -- layout check fails, we still want to accept this as an empty block.++-- | Parse a single line that may be continued via layout.+indentedLine :: Parser a -> Parser a+indentedLine p =+  setLayout *> p <* popLayout <* popLayout+  -- We have to pop twice, because the first successful token+  -- moves from 'At' to 'After', so we have to remove both.++-- | Parse a block of items which can be delimited either via+-- layout or via explicit delimiters as specified.+--+-- Assumes that the parser for items does not accept the empty string.+--+indentedOrExplicitBlock :: Parser open -> Parser close -> Parser sep -> Parser a -> Parser [a]+indentedOrExplicitBlock open close sep p =+      explicitBlock open close sep p+  <|> (concat <$> indentedBlock (sepEndBy1 p sep))++-- | Parse a block of items that are delimited via explicit delimiters.+-- Layout is disabled/reset for the scope of this block.+--+explicitBlock :: Parser open -> Parser close -> Parser sep -> Parser a -> Parser [a]+explicitBlock open close sep p =+  resetLayout *> open *> sepEndBy p sep <* close <* popLayout++-- | Symbolic lexeme. Stands on its own.+sym :: String -> Parser String+sym x =+  lexeme (string x)++-- | Located variant of 'sym'.+locSym :: String -> Parser (Located String)+locSym x =+  locLexeme (string x)++semi, comma, colon, dcolon, dot :: Parser String+semi   = sym ";"+comma  = sym ","+colon  = sym ":" -- Note: not a reserved symbol; use with care+dcolon = sym "::" -- Note: not a reserved symbol; use with care+dot    = sym "." -- Note: not a reserved symbol; use with care++-- | Parses a block via layout or explicit braces and semicolons.+--+-- Assumes that the parser for items does not accept the empty string.+--+-- However, even in layouted mode, we are allowing semicolons to+-- separate block contents. We also allow semicolons at the beginning,+-- end, and multiple subsequent semicolons, so the resulting parser+-- provides the illusion of allowing empty items.+--+block :: Parser a -> Parser [a]+block =+  indentedOrExplicitBlock (sym "{" *> many semi) (sym "}") (some semi)++-- | Parses a block with explicit braces and commas as separator.+-- Used for record constructors in datatypes.+--+explicitCommaBlock :: Parser a -> Parser [a]+explicitCommaBlock =+  explicitBlock (sym "{") (sym "}") comma++--------------------------------------------------------------------++reservedNames :: S.HashSet String+reservedNames = S.fromList+  [ -- reserved words used in fixpoint+    "SAT"+  , "UNSAT"+  , "true"+  , "false"+  , "mod"+  , "data"+  , "Bexp"+  -- , "True"+  -- , "Int"+  , "import"+  , "if", "then", "else"+  , "func"+  , "autorewrite"+  , "rewrite"++  -- reserved words used in liquid haskell+  , "forall"+  , "coerce"+  , "exists"+  , "module"+  , "spec"+  , "where"+  , "decrease"+  , "lazyvar"+  , "LIQUID"+  , "lazy"+  , "local"+  , "assert"+  , "assume"+  , "automatic-instances"+  , "autosize"+  , "axiomatize"+  , "bound"+  , "class"+  , "data"+  , "define"+  , "defined"+  , "embed"+  , "expression"+  , "import"+  , "include"+  , "infix"+  , "infixl"+  , "infixr"+  , "inline"+  , "instance"+  , "invariant"+  , "measure"+  , "newtype"+  , "predicate"+  , "qualif"+  , "reflect"+  , "type"+  , "using"+  , "with"+  , "in"+  ]++-- TODO: This is currently unused.+--+-- The only place where this is used in the original parsec code is in the+-- Text.Parsec.Token.operator parser.+--+_reservedOpNames :: [String]+_reservedOpNames =+  [ "+", "-", "*", "/", "\\", ":"+  , "<", ">", "<=", ">=", "=", "!=" , "/="+  , "mod", "and", "or"+  --, "is"+  , "&&", "||"+  , "~", "=>", "==>", "<=>"+  , "->"+  , ":="+  , "&", "^", "<<", ">>", "--"+  , "?", "Bexp"+  , "'"+  , "_|_"+  , "|"+  , "<:"+  , "|-"+  , "::"+  , "."+  ]++{-+lexer :: Monad m => Token.GenTokenParser String u m+lexer = Token.makeTokenParser languageDef+-}++-- | Consumes a line comment.+lhLineComment :: Parser ()+lhLineComment =+  L.skipLineComment "// "++-- | Consumes a block comment.+lhBlockComment :: Parser ()+lhBlockComment =+  L.skipBlockComment "/* " "*/"++-- | Parser that consumes a single char within an identifier (not start of identifier).+identLetter :: Parser Char+identLetter =+  alphaNumChar <|> oneOf ("_" :: String)++-- | Parser that consumes a single char within an operator (not start of operator).+opLetter :: Parser Char+opLetter =+  oneOf (":!#$%&*+./<=>?@\\^|-~'" :: String)++-- | Parser that consumes the given reserved word.+--+-- The input token cannot be longer than the given name.+--+-- NOTE: we currently don't double-check that the reserved word is in the+-- list of reserved words.+--+reserved :: String -> Parser ()+reserved x =+  void $ lexeme (try (string x <* notFollowedBy identLetter))++locReserved :: String -> Parser (Located String)+locReserved x =+  locLexeme (try (string x <* notFollowedBy identLetter))++-- | Parser that consumes the given reserved operator.+--+-- The input token cannot be longer than the given name.+--+-- NOTE: we currently don't double-check that the reserved operator is in the+-- list of reserved operators.+--+reservedOp :: String -> Parser ()+reservedOp x =+  void $ lexeme (try (string x <* notFollowedBy opLetter))++-- | Parser that consumes the given symbol.+--+-- The difference with 'reservedOp' is that the given symbol is seen+-- as a token of its own, so the next character that follows does not+-- matter.+--+-- symbol :: String -> Parser String+-- symbol x =+--   L.symbol spaces (string x)++parens, brackets, angles, braces :: Parser a -> Parser a+parens   = between (sym "(") (sym ")")+brackets = between (sym "[") (sym "]")+angles   = between (sym "<") (sym ">")+braces   = between (sym "{") (sym "}")++locParens :: Parser a -> Parser (Located a)+locParens p =+  (\ (Loc l1 _ _) a (Loc _ l2 _) -> Loc l1 l2 a) <$> locSym "(" <*> p <*> locSym ")"++-- | Parses a string literal as a lexeme. This is based on megaparsec's+-- 'charLiteral' parser, which claims to handle all the single-character+-- escapes defined by the Haskell grammar.+--+stringLiteral :: Parser String+stringLiteral =+  lexeme stringR <?> "string literal"++locStringLiteral :: Parser (Located String)+locStringLiteral =+  locLexeme stringR <?> "string literal"++stringR :: Parser String+stringR =+  char '\"' *> manyTill L.charLiteral (char '\"')++-- | Consumes a float literal lexeme.+double :: Parser Double+double = lexeme L.float <?> "float literal"++-- identifier :: Parser String+-- identifier = Token.identifier lexer++-- | Consumes a natural number literal lexeme, which can be+-- in decimal, octal and hexadecimal representation.+--+-- This does not parse negative integers. Unary minus is available+-- as an operator in the expression language.+--+natural :: Parser Integer+natural =+  lexeme naturalR <?> "nat literal"++locNatural :: Parser (Located Integer)+locNatural =+  locLexeme naturalR <?> "nat literal"++naturalR :: Parser Integer+naturalR =+      try (char '0' *> char' 'x') *> L.hexadecimal+  <|> try (char '0' *> char' 'o') *> L.octal+  <|> L.decimal++-- | Raw (non-whitespace) parser for an identifier adhering to certain conditions.+--+-- The arguments are as follows, in order:+--+-- * the parser for the initial character,+-- * a predicate indicating which subsequent characters are ok,+-- * a check for the entire identifier to be applied in the end,+-- * an error message to display if the final check fails.+--+condIdR :: Parser Char -> (Char -> Bool) -> (String -> Bool) -> String -> Parser Symbol+condIdR initial okChars condition msg = do+  s <- (:) <$> initial <*> takeWhileP Nothing okChars+  if condition s+    then pure (symbol s)+    else fail (msg <> " " <> show s)++-- TODO: The use of the following parsers is unsystematic.++-- | Raw parser for an identifier starting with an uppercase letter.+--+-- See Note [symChars].+--+upperIdR :: Parser Symbol+upperIdR =+  condIdR upperChar (`S.member` symChars) (const True) "unexpected"++-- | Raw parser for an identifier starting with a lowercase letter.+--+-- See Note [symChars].+--+lowerIdR :: Parser Symbol+lowerIdR =+  condIdR (lowerChar <|> char '_') (`S.member` symChars) isNotReserved "unexpected reserved word"++-- | Raw parser for an identifier starting with any letter.+--+-- See Note [symChars].+--+symbolR :: Parser Symbol+symbolR =+  condIdR (letterChar <|> char '_') (`S.member` symChars) isNotReserved "unexpected reserved word"++isNotReserved :: String -> Bool+isNotReserved s = not (s `S.member` reservedNames)++-- | Predicate version to check if the characer is a valid initial+-- character for 'lowerIdR'.+--+-- TODO: What is this needed for?+--+isSmall :: Char -> Bool+isSmall c = Char.isLower c || c == '_'++-- Note [symChars].+--+-- The parser 'symChars' is very permissive. In particular, we allow+-- dots (for qualified names), and characters such as @$@ to be able+-- to refer to identifiers as they occur in e.g. GHC Core.++----------------------------------------------------------------+------------------------- Expressions --------------------------+----------------------------------------------------------------++-- | Lexeme version of 'upperIdR'.+--+upperIdP :: Parser Symbol+upperIdP  =+  lexeme upperIdR <?> "upperIdP"++-- | Lexeme version of 'lowerIdR'.+--+lowerIdP :: Parser Symbol+lowerIdP  =+  lexeme lowerIdR <?> "lowerIdP"++-- | Unconstrained identifier, lower- or uppercase.+--+-- Must not be a reserved word.+--+-- Lexeme version of 'symbolR'.+--+symbolP :: Parser Symbol+symbolP =+  lexeme symbolR <?> "identifier"++-- The following are located versions of the lexeme identifier parsers.++locSymbolP, locLowerIdP, locUpperIdP :: Parser LocSymbol+locLowerIdP = locLexeme lowerIdR+locUpperIdP = locLexeme upperIdR+locSymbolP  = locLexeme symbolR++-- | Parser for literal numeric constants: floats or integers without sign.+constantP :: Parser Constant+constantP =+     try (R <$> double)   -- float literal+ <|> I <$> natural        -- nat literal++-- | Parser for literal string contants.+symconstP :: Parser SymConst+symconstP = SL . T.pack <$> stringLiteral++-- | Parser for "atomic" expressions.+--+-- This parser is reused by Liquid Haskell.+--+expr0P :: Parser Expr+expr0P+  =  trueP -- constant "true"+ <|> falseP -- constant "false"+ <|> fastIfP EIte exprP -- "if-then-else", starts with "if"+ <|> coerceP exprP -- coercion, starts with "coerce"+ <|> (ESym <$> symconstP) -- string literal, starts with double-quote+ <|> (ECon <$> constantP) -- numeric literal, starts with a digit+ <|> (reservedOp "_|_" >> return EBot) -- constant bottom, equivalent to "false"+ <|> lamP -- lambda abstraction, starts with backslash+ <|> try tupleP -- tuple expressions, starts with "("+ <|> try (parens exprP) -- parenthesised expression, starts with "("+ <|> try (parens exprCastP) -- explicit type annotation, starts with "(", TODO: should be an operator rather than require parentheses?+ <|> EVar <$> symbolP -- identifier, starts with any letter or underscore+ <|> try (brackets (pure ()) >> emptyListP) -- empty list, start with "["+ <|> try (brackets exprP >>= singletonListP) -- singleton list, starts with "["+ --+ -- Note:+ --+ -- In the parsers above, it is important that *all* parsers starting with "("+ -- are prefixed with "try". This is because expr0P itself is chained with+ -- additional parsers in funAppP ...++emptyListP :: Parser Expr+emptyListP = do+  e <- empList <$> get+  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+  case f of+    Nothing -> fail "No parsing support for singleton lists"+    Just s  -> return $ s e++-- | Parser for an explicitly type-annotated expression.+exprCastP :: Parser Expr+exprCastP+  = do e  <- exprP+       try dcolon <|> colon -- allow : or :: *and* allow following symbols+       so <- sortP+       return $ ECst e so++fastIfP :: (Expr -> a -> a -> a) -> Parser a -> Parser a+fastIfP f bodyP+  = do reserved "if"+       p <- predP+       reserved "then"+       b1 <- bodyP+       reserved "else"+       b2 <- bodyP+       return $ f p b1 b2++coerceP :: Parser Expr -> Parser Expr+coerceP p = do+  reserved "coerce"+  (s, t) <- parens (pairP sortP (reservedOp "~") sortP)+  e      <- p+  return $ ECoerc s t e++++{-+qmIfP f bodyP+  = parens $ do+      p  <- predP+      reserved "?"+      b1 <- bodyP+      colon+      b2 <- bodyP+      return $ f p b1 b2+-}++-- | Parser for atomic expressions plus function applications.+--+-- Base parser used in 'exprP' which adds in other operators.+--+expr1P :: Parser Expr+expr1P+  =  try funAppP+ <|> expr0P++-- | Expressions+exprP :: Parser Expr+exprP =+  do+    table <- gets fixityTable+    makeExprParser expr1P (flattenOpTable table)++data Assoc = AssocNone | AssocLeft | AssocRight++data Fixity+  = FInfix   {fpred :: Maybe Int, fname :: String, fop2 :: Maybe (Expr -> Expr -> Expr), fassoc :: Assoc}+  | FPrefix  {fpred :: Maybe Int, fname :: String, fop1 :: Maybe (Expr -> Expr)}+  | FPostfix {fpred :: Maybe Int, fname :: String, fop1 :: Maybe (Expr -> Expr)}+++-- | An OpTable stores operators by their fixity.+--+-- Fixity levels range from 9 (highest) to 0 (lowest).+type OpTable = IM.IntMap [Operator Parser Expr] -- [[Operator Parser Expr]]++-- | Transform an operator table to the form expected by 'makeExprParser',+-- which wants operators sorted by decreasing priority.+--+flattenOpTable :: OpTable -> [[Operator Parser Expr]]+flattenOpTable =+  (snd <$>) <$> IM.toDescList++-- | Add an operator to the parsing state.+addOperatorP :: Fixity -> Parser ()+addOperatorP op+  = modify $ \s -> s{ fixityTable = addOperator op (fixityTable s)+                    , fixityOps   = op:fixityOps s+                    }++-- | Parses any of the known infix operators.+infixSymbolP :: Parser Symbol+infixSymbolP = do+  ops <- infixOps <$> get+  choice (reserved' <$> ops)+  where+    infixOps st = [s | FInfix _ s _ _ <- fixityOps st]+    reserved' x = reserved x >> return (symbol x)++-- | Located version of 'infixSymbolP'.+locInfixSymbolP :: Parser (Located Symbol)+locInfixSymbolP = do+  ops <- infixOps <$> get+  choice (reserved' <$> ops)+  where+    infixOps st = [s | FInfix _ s _ _ <- fixityOps st]+    reserved' x = locReserved x >>= \ (Loc l1 l2 _) -> return (Loc l1 l2 (symbol x))++-- | Helper function that turns an associativity into the right constructor for 'Operator'.+mkInfix :: Assoc -> parser (expr -> expr -> expr) -> Operator parser expr+mkInfix AssocLeft  = InfixL+mkInfix AssocRight = InfixR+mkInfix AssocNone  = InfixN++-- | Add the given operator to the operator table.+addOperator :: Fixity -> OpTable -> OpTable+addOperator (FInfix p x f assoc) ops+ = insertOperator (makePrec p) (mkInfix assoc (reservedOp x >> return (makeInfixFun x f))) ops+addOperator (FPrefix p x f) ops+ = insertOperator (makePrec p) (Prefix (reservedOp x >> return (makePrefixFun x f))) ops+addOperator (FPostfix p x f) ops+ = insertOperator (makePrec p) (Postfix (reservedOp x >> return (makePrefixFun x f))) ops++-- | Helper function for computing the priority of an operator.+--+-- If no explicit priority is given, a priority of 9 is assumed.+--+makePrec :: Maybe Int -> Int+makePrec = fromMaybe 9++makeInfixFun :: String -> Maybe (Expr -> Expr -> Expr) -> Expr -> Expr -> Expr+makeInfixFun x = fromMaybe (\e1 e2 -> EApp (EApp (EVar $ symbol x) e1) e2)++makePrefixFun :: String -> Maybe (Expr -> Expr) -> Expr -> Expr+makePrefixFun x = fromMaybe (EApp (EVar $ symbol x))++-- | Add an operator at the given priority to the operator table.+insertOperator :: Int -> Operator Parser Expr -> OpTable -> OpTable+insertOperator i op = IM.alter (Just . (op :) . fromMaybe []) i++-- | The initial (empty) operator table.+initOpTable :: OpTable+initOpTable = IM.empty++-- | Built-in operator table, parameterised over the composition function.+bops :: Maybe Expr -> OpTable+bops cmpFun = foldl' (flip addOperator) initOpTable builtinOps+  where+    -- Built-in Haskell operators, see https://www.haskell.org/onlinereport/decls.html#fixity+    builtinOps :: [Fixity]+    builtinOps = [ FPrefix (Just 9) "-"   (Just ENeg)+                 , FInfix  (Just 7) "*"   (Just $ EBin Times) AssocLeft+                 , FInfix  (Just 7) "/"   (Just $ EBin Div)   AssocLeft+                 , FInfix  (Just 6) "-"   (Just $ EBin Minus) AssocLeft+                 , FInfix  (Just 6) "+"   (Just $ EBin Plus)  AssocLeft+                 , FInfix  (Just 5) "mod" (Just $ EBin Mod)   AssocLeft -- Haskell gives mod 7+                 , FInfix  (Just 9) "."   applyCompose        AssocRight+                 ]+    applyCompose :: Maybe (Expr -> Expr -> Expr)+    applyCompose = (\f x y -> (f `eApps` [x,y])) <$> cmpFun++-- | Parser for function applications.+--+-- Andres, TODO: Why is this so complicated?+--+funAppP :: Parser Expr+funAppP            =  litP <|> exprFunP <|> simpleAppP+  where+    exprFunP = mkEApp <$> funSymbolP <*> funRhsP+    funRhsP  =  some expr0P+            <|> parens innerP+    innerP   = brackets (sepBy exprP semi)++    -- TODO:AZ the parens here should be superfluous, but it hits an infinite loop if removed+    simpleAppP     = EApp <$> parens exprP <*> parens exprP+    funSymbolP     = locSymbolP++-- | Parser for tuple expressions (two or more components).+tupleP :: Parser Expr+tupleP = do+  Loc l1 l2 (first, rest) <- locParens ((,) <$> exprP <* comma <*> sepBy1 exprP comma) -- at least two components necessary+  let cons = symbol $ "(" ++ replicate (length rest) ',' ++ ")" -- stored in prefix form+  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))+litP :: Parser Expr+litP = do reserved "lit"+          l <- stringLiteral+          t <- sortP+          return $ ECon $ L (T.pack l) t++-- | Parser for lambda abstractions.+lamP :: Parser Expr+lamP+  = do reservedOp "\\"+       x <- symbolP+       colon -- TODO: this should probably be reservedOp instead+       t <- sortP+       reservedOp "->"+       e  <- exprP+       return $ ELam (x, t) e++varSortP :: Parser Sort+varSortP  = FVar  <$> parens intP++-- | Parser for function sorts without the "func" keyword.+funcSortP :: Parser Sort+funcSortP = parens $ mkFFunc <$> intP <* comma <*> sortsP++sortsP :: Parser [Sort]+sortsP = try (brackets (sepBy sortP semi)) +      <|> (brackets (sepBy sortP comma)) ++-- | Parser for sorts (types).+sortP    :: Parser Sort+sortP    = sortP' (many sortArgP)++sortArgP :: Parser Sort+sortArgP = sortP' (return [])++{-+sortFunP :: Parser Sort+sortFunP+   =  try (string "@" >> varSortP)+  <|> (fTyconSort <$> fTyConP)+-}++-- | Parser for sorts, parameterised over the parser for arguments.+--+-- TODO, Andres: document the parameter better.+--+sortP' :: Parser [Sort] -> Parser Sort+sortP' appArgsP+   =  parens sortP -- parenthesised sort, starts with "("+  <|> (reserved "func" >> funcSortP) -- function sort, starts with "func"+  <|> (fAppTC listFTyCon . pure <$> brackets sortP)+  -- <|> bvSortP -- Andres: this looks unreachable, as it starts with "("+  <|> (fAppTC <$> fTyConP <*> appArgsP)+  <|> (fApp   <$> tvarP   <*> appArgsP)++tvarP :: Parser Sort+tvarP+   =  (string "@" >> varSortP)+  <|> (FObj . symbol <$> lowerIdP)+++fTyConP :: Parser FTycon+fTyConP+  =   (reserved "int"     >> return intFTyCon)+  <|> (reserved "Integer" >> return intFTyCon)+  <|> (reserved "Int"     >> return intFTyCon)+  -- <|> (reserved "int"     >> return intFTyCon) -- TODO:AZ duplicate?+  <|> (reserved "real"    >> return realFTyCon)+  <|> (reserved "bool"    >> return boolFTyCon)+  <|> (reserved "num"     >> return numFTyCon)+  <|> (reserved "Str"     >> return strFTyCon)+  <|> (symbolFTycon      <$> locUpperIdP)++-- | Bit-Vector Sort+bvSortP :: Parser Sort+bvSortP = mkSort <$> (bvSizeP "Size32" S32 <|> bvSizeP "Size64" S64)+  where+    bvSizeP ss s = do+      parens (reserved "BitVec" >> reserved ss)+      return s+++--------------------------------------------------------------------------------+-- | Predicates ----------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Parser for "atomic" predicates.+--+-- This parser is reused by Liquid Haskell.+--+pred0P :: Parser Expr+pred0P =  trueP -- constant "true"+      <|> falseP -- constant "false"+      <|> (reservedOp "??" >> makeUniquePGrad)+      <|> 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 "("+      <|> (reservedOp "?" *> exprP)+      <|> try funAppP+      <|> EVar <$> symbolP -- identifier, starts with any letter or underscore+      <|> (reservedOp "&&" >> pGAnds <$> predsP) -- built-in prefix and+      <|> (reservedOp "||" >> POr  <$> predsP) -- built-in prefix or++makeUniquePGrad :: Parser Expr+makeUniquePGrad+  = do uniquePos <- getSourcePos+       return $ PGrad (KV $ symbol $ show uniquePos) mempty (srcGradInfo uniquePos) mempty++-- qmP    = reserved "?" <|> reserved "Bexp"++-- | Parser for the reserved constant "true".+trueP :: Parser Expr+trueP  = reserved "true"  >> return PTrue++-- | Parser for the reserved constant "false".+falseP :: Parser Expr+falseP = reserved "false" >> return PFalse++kvarPredP :: Parser Expr+kvarPredP = PKVar <$> kvarP <*> substP++kvarP :: Parser KVar+kvarP = KV <$> lexeme (char '$' *> symbolR)++substP :: Parser Subst+substP = mkSubst <$> many (brackets $ pairP symbolP aP exprP)+  where+    aP = reservedOp ":="++-- | Parses a semicolon-separated bracketed list of predicates.+--+-- Used as the argument of the prefix-versions of conjunction and+-- disjunction.+--+predsP :: Parser [Expr]+predsP = brackets $ sepBy predP semi++-- | Parses a predicate.+--+-- Unlike for expressions, there is a built-in operator list.+--+predP  :: Parser Expr+predP  = makeExprParser pred0P lops+  where+    lops = [ [Prefix (reservedOp "~"    >> return PNot)]+           , [Prefix (reserved   "not"  >> return PNot)]+           , [InfixR (reservedOp "&&"   >> return pGAnd)]+           , [InfixR (reservedOp "||"   >> return (\x y -> POr [x,y]))]+           , [InfixR (reservedOp "=>"   >> return PImp)]+           , [InfixR (reservedOp "==>"  >> return PImp)]+           , [InfixR (reservedOp "="    >> return PIff)]+           , [InfixR (reservedOp "<=>"  >> return PIff)]]++-- | Parses a relation predicate.+--+-- Binary relations connect expressions and predicates.+--+predrP :: Parser Expr+predrP =+  (\ e1 r e2 -> r e1 e2) <$> exprP <*> brelP <*> exprP++-- | Parses a relation symbol.+--+-- There is a built-in table of available relations.+--+brelP ::  Parser (Expr -> Expr -> Expr)+brelP =  (reservedOp "==" >> return (PAtom Eq))+     <|> (reservedOp "="  >> return (PAtom Eq))+     <|> (reservedOp "~~" >> return (PAtom Ueq))+     <|> (reservedOp "!=" >> return (PAtom Ne))+     <|> (reservedOp "/=" >> return (PAtom Ne))+     <|> (reservedOp "!~" >> return (PAtom Une))+     <|> (reservedOp "<"  >> return (PAtom Lt))+     <|> (reservedOp "<=" >> return (PAtom Le))+     <|> (reservedOp ">"  >> return (PAtom Gt))+     <|> (reservedOp ">=" >> return (PAtom Ge))++--------------------------------------------------------------------------------+-- | BareTypes -----------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Refa+refaP :: Parser Expr+refaP =  try (pAnd <$> brackets (sepBy predP semi))+     <|> predP+++-- | (Sorted) Refinements with configurable sub-parsers+refBindP :: Parser Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a+refBindP bp rp kindP+  = braces $ do+      x  <- bp+      t  <- kindP+      reservedOp "|"+      ra <- rp <* spaces+      return $ t (Reft (x, ra))+++-- bindP      = symbol    <$> (lowerIdP <* colon)+-- | Binder (lowerIdP <* colon)+bindP :: Parser Symbol+bindP = symbolP <* colon++optBindP :: Symbol -> Parser Symbol+optBindP x = try bindP <|> return x++-- | (Sorted) Refinements+refP :: Parser (Reft -> a) -> Parser a+refP       = refBindP bindP refaP++-- | (Sorted) Refinements with default binder+refDefP :: Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a+refDefP x  = refBindP (optBindP x)++--------------------------------------------------------------------------------+-- | Parsing Data Declarations -------------------------------------------------+--------------------------------------------------------------------------------++dataFieldP :: Parser DataField+dataFieldP = DField <$> locSymbolP <* colon <*> sortP++dataCtorP :: Parser DataCtor+dataCtorP  = DCtor <$> locSymbolP+                   <*> braces (sepBy dataFieldP comma)++dataDeclP :: Parser DataDecl+dataDeclP  = DDecl <$> fTyConP <*> intP <* reservedOp "="+                   <*> brackets (many (reservedOp "|" *> dataCtorP))++--------------------------------------------------------------------------------+-- | Parsing Qualifiers --------------------------------------------------------+--------------------------------------------------------------------------------++-- | Qualifiers+qualifierP :: Parser Sort -> Parser Qualifier+qualifierP tP = do+  pos    <- getSourcePos+  n      <- upperIdP+  params <- parens $ sepBy1 (qualParamP tP) comma+  _      <- colon+  body   <- predP+  return  $ mkQual n params body pos++qualParamP :: Parser Sort -> Parser QualParam+qualParamP tP = do+  x     <- symbolP+  pat   <- qualPatP+  _     <- colon+  t     <- tP+  return $ QP x pat t++qualPatP :: Parser QualPattern+qualPatP+   =  (reserved "as" >> qualStrPatP)+  <|> return PatNone++qualStrPatP :: Parser QualPattern+qualStrPatP+   = (PatExact <$> symbolP)+  <|> parens (    (uncurry PatPrefix <$> pairP symbolP dot qpVarP)+              <|> (uncurry PatSuffix <$> pairP qpVarP  dot symbolP) )+++qpVarP :: Parser Int+qpVarP = char '$' *> intP++symBindP :: Parser a -> Parser (Symbol, a)+symBindP = pairP symbolP colon++pairP :: Parser a -> Parser z -> Parser b -> Parser (a, b)+pairP xP sepP yP = (,) <$> xP <* sepP <*> yP++---------------------------------------------------------------------+-- | Axioms for Symbolic Evaluation ---------------------------------+---------------------------------------------------------------------++autoRewriteP :: Parser AutoRewrite+autoRewriteP = do+  args       <- sepBy sortedReftP spaces+  _          <- spaces+  _          <- reserved "="+  _          <- spaces+  (lhs, rhs) <- braces $+      pairP exprP (reserved "=") exprP+  return $ AutoRewrite args lhs rhs+++defineP :: Parser Equation+defineP = do+  name   <- symbolP+  params <- parens        $ sepBy (symBindP sortP) comma+  sort   <- colon        *> sortP+  body   <- reserved "=" *> braces (+              if sort == boolSort then predP else exprP+               )+  return  $ mkEquation name params body sort++matchP :: Parser Rewrite+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+---------------------------------------------------------------------+-- | Parsing Constraints (.fq files) --------------------------------+---------------------------------------------------------------------++-- Entities in Query File+data Def a+  = Srt !Sort+  | Cst !(SubC a)+  | Wfc !(WfC a)+  | Con !Symbol !Sort+  | Dis !Symbol !Sort+  | Qul !Qualifier+  | Kut !KVar+  | Pack !KVar !Int+  | IBind !Int !Symbol !SortedReft+  | EBind !Int !Symbol !Sort+  | Opt !String+  | Def !Equation+  | Mat !Rewrite+  | Expand ![(Int,Bool)]+  | Adt  !DataDecl+  | AutoRW !Int !AutoRewrite+  | RWMap ![(Int,Int)]+  deriving (Show, Generic)+  --  Sol of solbind+  --  Dep of FixConstraint.dep++fInfoOptP :: Parser (FInfoWithOpts ())+fInfoOptP = do ps <- many defP+               return $ FIO (defsFInfo ps) [s | Opt s <- ps]++fInfoP :: Parser (FInfo ())+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)+    <|> 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)+    <|> Opt    <$> (reserved "fixpoint"    >> stringLiteral)+    <|> Def    <$> (reserved "define"      >> defineP)+    <|> Mat    <$> (reserved "match"       >> matchP)+    <|> Expand <$> (reserved "expand"      >> pairsP intP boolP)+    <|> Adt    <$> (reserved "data"        >> dataDeclP)+    <|> AutoRW <$> (reserved "autorewrite" >> intP) <*> autoRewriteP+    <|> RWMap  <$> (reserved "rewrite"     >> pairsP intP intP)+++sortedReftP :: Parser SortedReft+sortedReftP = refP (RR <$> (sortP <* spaces))++wfCP :: Parser (WfC ())+wfCP = do reserved "env"+          env <- envP+          reserved "reft"+          r   <- sortedReftP+          let [w] = wfC env r ()+          return w++subCP :: Parser (SubC ())+subCP = do pos <- getSourcePos+           reserved "env"+           env <- envP+           reserved "lhs"+           lhs <- sortedReftP+           reserved "rhs"+           rhs <- sortedReftP+           reserved "id"+           i   <- natural <* spaces+           tag <- tagP+           pos' <- getSourcePos+           return $ subC' env lhs rhs i tag pos pos'++subC' :: IBindEnv+      -> SortedReft+      -> SortedReft+      -> Integer+      -> Tag+      -> SourcePos+      -> SourcePos+      -> SubC ()+subC' env lhs rhs i tag l l'+  = case cs of+      [c] -> c+      _   -> die $ err sp $ "RHS without single conjunct at" <+> pprint l'+    where+       cs = subC env lhs rhs (Just i) tag ()+       sp = SS l l'+++tagP  :: Parser [Int]+tagP  = reserved "tag" >> spaces >> brackets (sepBy intP semi)++envP  :: Parser IBindEnv+envP  = do binds <- brackets $ sepBy (intP <* spaces) semi+           return $ insertsIBindEnv binds emptyIBindEnv++intP :: Parser Int+intP = fromInteger <$> natural++boolP :: Parser Bool+boolP = (reserved "True" >> return True)+    <|> (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+  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]+    lts        = fromListSEnv       [(x, t)             | Con x t     <- defs]+    dts        = fromListSEnv       [(x, t)             | Dis x t     <- defs]+    kts        = KS $ S.fromList    [k                  | Kut k       <- defs]+    qs         =                    [q                  | Qul q       <- defs]+    binfo      = mempty+    expand     = M.fromList         [(fromIntegral i, f)| Expand fs   <- defs, (i,f) <- fs]+    eqs        =                    [e                  | Def e       <- defs]+    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+                 where+                   insert map (cid, arId) =+                     case M.lookup arId autoRWs of+                       Just rewrite ->+                         M.insertWith (++) (fromIntegral cid) [rewrite] map+                       Nothing ->+                         map+    cid        = fromJust . sid+    ae         = AEnv eqs rews expand rwMap+    adts       =                    [d                  | Adt d       <- defs]+    -- msg    = show $ "#Lits = " ++ (show $ length consts)++---------------------------------------------------------------------+-- | Interacting with Fixpoint --------------------------------------+---------------------------------------------------------------------++fixResultP :: Parser a -> Parser (FixResult a)+fixResultP pp+  =  (reserved "SAT"   >> return (Safe mempty))+ <|> (reserved "UNSAT" >> Unsafe mempty <$> brackets (sepBy pp comma))+ <|> (reserved "CRASH" >> crashP pp)++crashP :: Parser a -> Parser (FixResult a)+crashP pp = do+  i   <- pp+  msg <- takeWhileP Nothing (const True) -- consume the rest of the input+  return $ Crash [i] msg++predSolP :: Parser Expr+predSolP = parens (predP  <* (comma >> iQualP))++iQualP :: Parser [Symbol]+iQualP = upperIdP >> parens (sepBy symbolP comma)++solution1P :: Parser (KVar, Expr)+solution1P = do+  reserved "solution:"+  k  <- kvP+  reservedOp ":="+  ps <- brackets $ sepBy predSolP semi+  return (k, simplify $ PAnd ps)+  where+    kvP = try kvarP <|> (KV <$> symbolP)++solutionP :: Parser (M.HashMap KVar Expr)+solutionP = M.fromList <$> sepBy solution1P spaces++solutionFileP :: Parser (FixResult Integer, M.HashMap KVar Expr)+solutionFileP = (,) <$> fixResultP natural <*> solutionP++--------------------------------------------------------------------------------++-- | Parse via the given parser, and obtain the rest of the input+-- as well as the final source position.+--+remainderP :: Parser a -> Parser (a, String, SourcePos)+remainderP p+  = do res <- p+       str <- getInput+       pos <- getSourcePos+       return (res, str, pos)++-- | Initial parser state.+initPState :: Maybe Expr -> PState+initPState cmpFun = PState { fixityTable = bops cmpFun+                           , empList     = Nothing+                           , singList    = Nothing+                           , fixityOps   = []+                           , supply      = 0+                           , layoutStack = Empty+                           }++-- | Entry point for parsing, for testing.+--+-- Take the top-level parser, the source file name, and the input as a string.+-- Fails with an exception on a parse error.+--+doParse' :: Parser a -> SourceName -> String -> a+doParse' parser fileName input =+  case runParser (evalStateT (spaces *> parser <* eof) (initPState Nothing)) fileName input of+    Left peb@(ParseErrorBundle errors posState) -> -- parse errors; we extract the first error from the error bundle+      let+        ((_, pos) :| _, _) = attachSourcePos errorOffset errors posState+      in+        die $ err (SS pos pos) (dErr peb)+    Right r -> r -- successful parse with no remaining input+  where+    -- Turns the multiline error string from megaparsec into a pretty-printable Doc.+    dErr :: ParseErrorBundle String Void -> Doc+    dErr e = vcat (map text (lines (errorBundlePretty e)))++-- | Function to test parsers interactively.+parseTest' :: Show a => Parser a -> String -> IO ()+parseTest' parser input =+  parseTest (evalStateT parser (initPState Nothing)) input++-- errorSpan :: ParseError -> SrcSpan+-- errorSpan e = SS l l where l = errorPos e++parseFromFile :: Parser b -> SourceName -> IO b+parseFromFile p f = doParse' p f <$> readFile f++parseFromStdIn :: Parser a -> IO a+parseFromStdIn p = doParse' p "stdin" . T.unpack <$> T.getContents++-- | Obtain a fresh integer during the parsing process.+freshIntP :: Parser Integer+freshIntP = do n <- gets supply+               modify (\ s -> s{supply = n + 1})+               return n++---------------------------------------------------------------------+-- Standalone SMTLIB2 commands --------------------------------------+---------------------------------------------------------------------+commandsP :: Parser [Command]+commandsP = sepBy commandP semi++commandP :: Parser Command+commandP+  =  (reserved "var"      >> cmdVarP)+ <|> (reserved "push"     >> return Push)+ <|> (reserved "pop"      >> return Pop)+ <|> (reserved "check"    >> return CheckSat)+ <|> (reserved "assert"   >> (Assert Nothing <$> predP))+ <|> (reserved "distinct" >> (Distinct <$> brackets (sepBy exprP comma)))++cmdVarP :: Parser Command+cmdVarP = error "UNIMPLEMENTED: cmdVarP"+-- do+  -- x <- bindP+  -- t <- sortP+  -- return $ Declare x [] t++---------------------------------------------------------------------+-- Bundling Parsers into a Typeclass --------------------------------+---------------------------------------------------------------------++class Inputable a where+  rr  :: String -> a+  rr' :: String -> String -> a+  rr' _ = rr+  rr    = rr' ""++instance Inputable Symbol where+  rr' = doParse' symbolP++instance Inputable Constant where+  rr' = doParse' constantP++instance Inputable Expr where+  rr' = doParse' exprP++instance Inputable (FixResult Integer) where+  rr' = doParse' $ fixResultP natural++instance Inputable (FixResult Integer, FixSolution) where+  rr' = doParse' solutionFileP++instance Inputable (FInfo ()) where+  rr' = {- SCC "fInfoP" #-} doParse' fInfoP++instance Inputable (FInfoWithOpts ()) where+  rr' = {- SCC "fInfoWithOptsP" #-} doParse' fInfoOptP  instance Inputable Command where   rr' = doParse' commandP
src/Language/Fixpoint/Smt/Interface.hs view
@@ -16,6 +16,23 @@ --   http://www.smt-lib.org/ --   http://www.grammatech.com/resource/smt/SMTLIBTutorial.pdf +-- Note [Async SMT API]+--+-- The SMT solver is started in a separate process and liquid-fixpoint+-- communicates with it via pipes. This mechanism introduces some latency+-- since the queries need to reach the buffers in a separate process and+-- the OS has to switch contexts.+--+-- A remedy we currently try for this is to send multiple queries+-- together without waiting for the reply to each one, i.e. asynchronously.+-- We then collect the multiple answers after sending all of the queries.+--+-- The functions named @smt*Async@ implement this scheme.+--+-- An asynchronous thread is used to write the queries to prevent the+-- caller from blocking on IO, should the write buffer be full or should+-- an 'hFlush' call be necessary.+ module Language.Fixpoint.Smt.Interface (      -- * Commands@@ -36,11 +53,13 @@      -- * Execute Queries     , command-    , smtWrite+    , smtExit+    , smtSetMbqi      -- * Query API     , smtDecl     , smtDecls+    , smtDefineFunc     , smtAssert     , smtFuncDecl     , smtAssertAxiom@@ -49,6 +68,12 @@     , smtBracket, smtBracketAt     , smtDistinct     , smtPush, smtPop+    , smtAssertAsync+    , smtCheckUnsatAsync+    , readCheckUnsat+    , smtBracketAsyncAt+    , smtPushAsync+    , smtPopAsync      -- * Check Validity     , checkValid@@ -58,6 +83,9 @@      ) where +import           Control.Concurrent.Async (async, cancel)+import           Control.Concurrent.STM+  (TVar, atomically, modifyTVar, newTVarIO, readTVar, retry, writeTVar) import           Language.Fixpoint.Types.Config ( SMTSolver (..)                                                 , Config                                                 , solver@@ -65,7 +93,6 @@                                                 , gradual                                                 , stringTheory) import qualified Language.Fixpoint.Misc          as Misc-import qualified Language.Fixpoint.Types.Visitor as Vis import           Language.Fixpoint.Types.Errors import           Language.Fixpoint.Utils.Files import           Language.Fixpoint.Types         hiding (allowHO)@@ -84,22 +111,22 @@ #endif  import qualified Data.Text                as T-import           Data.Text.Format+-- import           Data.Text.Format import qualified Data.Text.IO             as TIO import qualified Data.Text.Lazy           as LT-import qualified Data.Text.Lazy.Builder   as Builder import qualified Data.Text.Lazy.IO        as LTIO import           System.Directory import           System.Console.CmdArgs.Verbosity import           System.Exit              hiding (die) import           System.FilePath-import           System.IO                (Handle, IOMode (..), hClose, hFlush, openFile)+import           System.IO import           System.Process import qualified Data.Attoparsec.Text     as A -- import qualified Data.HashMap.Strict      as M import           Data.Attoparsec.Internal.Types (Parser) import           Text.PrettyPrint.HughesPJ (text) import           Language.Fixpoint.SortCheck+import           Language.Fixpoint.Utils.Builder as Builder -- import qualified Language.Fixpoint.Types as F -- import           Language.Fixpoint.Types.PrettyPrint (tracepp) @@ -155,42 +182,50 @@ --------------------------------------------------------------------------------  --------------------------------------------------------------------------------+{-# SCC command #-} command              :: Context -> Command -> IO Response ---------------------------------------------------------------------------------command me !cmd       = say cmd >> hear cmd+command me !cmd       = say >> hear cmd   where     env               = ctxSymEnv me-    say               = smtWrite me . Builder.toLazyText . runSmt2 env+    say               = smtWrite me ({-# SCC "Command-runSmt2" #-} Builder.toLazyText (runSmt2 env cmd))     hear CheckSat     = smtRead me     hear (GetValue _) = smtRead me     hear _            = return Ok +smtExit :: Context -> IO ()+smtExit me = asyncCommand me Exit +smtSetMbqi :: Context -> IO ()+smtSetMbqi me = asyncCommand me SetMbqi+ smtWrite :: Context -> Raw -> IO () 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 -> hPutStrLnNow h $ format "; SMT Says: {}" (Only $ show r)) (ctxLog me)-      when (ctxVerbose me) $ LTIO.putStrLn $ format "SMT Says: {}" (Only $ show r)+      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 ++ 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@@ -200,7 +235,7 @@ valuesP = A.many1' pairP <* A.char ')'  pairP :: SmtParser (Symbol, T.Text)-pairP = {-# SCC "pairP" #-}+pairP = {- SCC "pairP" #-}   do A.skipSpace      A.char '('      !x <- symbolP@@ -210,10 +245,10 @@      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@@ -222,17 +257,19 @@        return $ "(" <> v <> ")"  smtWriteRaw      :: Context -> Raw -> IO ()-smtWriteRaw me !s = {-# SCC "smtWriteRaw" #-} do+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-  maybe (return ()) (`hPutStrLnNow` s) (ctxLog me)+  maybe (return ()) (`LTIO.hPutStrLn` s) (ctxLog me)  smtReadRaw       :: Context -> IO T.Text-smtReadRaw me    = {-# SCC "smtReadRaw" #-} TIO.hGetLine (ctxCin me)+smtReadRaw me    = {- SCC "smtReadRaw" #-} TIO.hGetLine (ctxCin me)+{-# SCC smtReadRaw  #-}  hPutStrLnNow     :: Handle -> LT.Text -> IO () hPutStrLnNow h !s = LTIO.hPutStrLn h s >> hFlush h+{-# SCC hPutStrLnNow #-}  -------------------------------------------------------------------------- -- | SMT Context ---------------------------------------------------------@@ -246,6 +283,7 @@        pre  <- smtPreamble cfg (solver cfg) me        createDirectoryIfMissing True $ takeDirectory smtFile        hLog <- openFile smtFile WriteMode+       hSetBuffering hLog $ BlockBuffering $ Just $ 1024*1024*64        let me' = me { ctxLog = Just hLog }        mapM_ (smtWrite me') pre        return me'@@ -271,18 +309,34 @@ makeProcess cfg   = do (hOut, hIn, _ ,pid) <- runInteractiveCommand $ smtCmd (solver cfg)        loud <- isLoud+       hSetBuffering hOut $ BlockBuffering $ Just $ 1024*1024*64+       hSetBuffering hIn $ BlockBuffering $ Just $ 1024*1024*64+       -- See Note [Async SMT API]+       queueTVar <- newTVarIO mempty+       writerAsync <- async $ forever $ do+         t <- atomically $ do+           builder <- readTVar queueTVar+           let t = Builder.toLazyText builder+           when (LT.null t) retry+           writeTVar queueTVar mempty+           return t+         LTIO.hPutStr hOut t+         hFlush hOut        return Ctx { ctxPid     = pid                   , ctxCin     = hIn                   , ctxCout    = hOut                   , ctxLog     = Nothing                   , ctxVerbose = loud                   , ctxSymEnv  = mempty+                  , ctxAsync   = writerAsync+                  , ctxTVar    = queueTVar                   }  -------------------------------------------------------------------------- cleanupContext :: Context -> IO ExitCode -------------------------------------------------------------------------- cleanupContext (Ctx {..}) = do+  cancel ctxAsync   hCloseMe "ctxCin"  ctxCin   hCloseMe "ctxCout" ctxCout   maybe (return ()) (hCloseMe "ctxLog") ctxLog@@ -344,7 +398,7 @@ smtDecls = mapM_ . uncurry . smtDecl  smtDecl :: Context -> Symbol -> Sort -> IO ()-smtDecl me x t = interact' me ({- notracepp msg $ -} Declare x ins' out')+smtDecl me x t = interact' me ({- notracepp msg $ -} Declare (symbolSafeText x) ins' out')   where     ins'       = sortSmtSort False env <$> ins     out'       = sortSmtSort False env     out@@ -352,7 +406,7 @@     _msg        = "smtDecl: " ++ showpp (x, t, ins, out)     env        = seData (ctxSymEnv me) -smtFuncDecl :: Context -> Symbol -> ([SmtSort],  SmtSort) -> IO ()+smtFuncDecl :: Context -> T.Text -> ([SmtSort],  SmtSort) -> IO () smtFuncDecl me x (ts, t) = interact' me (Declare x ts t)  smtDataDecl :: Context -> [DataDecl] -> IO ()@@ -374,6 +428,59 @@ smtAssert :: Context -> Expr -> IO () smtAssert me p  = interact' me (Assert Nothing p) +smtDefineFunc :: Context -> Symbol -> [(Symbol, F.Sort)] -> F.Sort -> Expr -> IO ()+smtDefineFunc me name params rsort e =+  let env = seData (ctxSymEnv me)+   in interact' me $+        DefineFunc+          name+          (map (sortSmtSort False env <$>) params)+          (sortSmtSort False env rsort)+          e++-----------------------------------------------------------------+-- Async calls to the smt+--+-- See Note [Async SMT API]+-----------------------------------------------------------------++asyncCommand :: Context -> Command -> IO ()+asyncCommand me cmd = do+  let env = ctxSymEnv me+      cmdText = {-# SCC "asyncCommand-runSmt2" #-} Builder.toLazyText $ runSmt2 env cmd+  asyncPutStrLn (ctxTVar me) cmdText+  maybe (return ()) (`LTIO.hPutStrLn` cmdText) (ctxLog me)+  where+    asyncPutStrLn :: TVar Builder.Builder -> LT.Text -> IO ()+    asyncPutStrLn tv t = atomically $+      modifyTVar tv (`mappend` (Builder.fromLazyText t `mappend` Builder.fromString "\n"))++smtAssertAsync :: Context -> Expr -> IO ()+smtAssertAsync me p  = asyncCommand me $ Assert Nothing p++smtCheckUnsatAsync :: Context -> IO ()+smtCheckUnsatAsync me = asyncCommand me CheckSat++smtBracketAsyncAt :: SrcSpan -> Context -> String -> IO a -> IO a+smtBracketAsyncAt sp x y z = smtBracketAsync x y z `catch` dieAt sp++smtBracketAsync :: Context -> String -> IO a -> IO a+smtBracketAsync me _msg a   = do+  smtPushAsync me+  r <- a+  smtPopAsync me+  return r++smtPushAsync, smtPopAsync   :: Context -> IO ()+smtPushAsync me = asyncCommand me Push+smtPopAsync me = asyncCommand me Pop++-----------------------------------------------------------------++{-# SCC readCheckUnsat #-}+readCheckUnsat :: Context -> IO Bool+readCheckUnsat me = respSat <$> smtRead me+ smtAssertAxiom :: Context -> Triggered Expr -> IO () smtAssertAxiom me p  = interact' me (AssertAx p) @@ -461,7 +568,7 @@ dataDeclarations :: SymEnv -> [[DataDecl]] dataDeclarations = orderDeclarations . map snd . F.toListSEnv . F.seData -funcSortVars :: F.SymEnv -> [(F.Symbol, ([F.SmtSort], F.SmtSort))]+funcSortVars :: F.SymEnv -> [(T.Text, ([F.SmtSort], F.SmtSort))] funcSortVars env  = [(var applyName  t       , appSort t) | t <- ts]                  ++ [(var coerceName t       , ([t1],t2)) | t@(t1, t2) <- ts]                  ++ [(var lambdaName t       , lamSort t) | t <- ts]@@ -503,31 +610,3 @@     notFun           = not . F.isFunctionSortedReft . (`F.RR` F.trueReft)     -- _notStr          = not . (F.strSort ==) . F.sr_sort . (`F.RR` F.trueReft) ------------------------------------------------------------------------------------ | 'orderDeclarations' sorts the data declarations such that each declarations---   only refers to preceding ones.----------------------------------------------------------------------------------orderDeclarations :: [F.DataDecl] -> [[F.DataDecl]]----------------------------------------------------------------------------------orderDeclarations ds = {- reverse -} (Misc.sccsWith f ds)-  where-    dM               = M.fromList [(F.ddTyCon d, d) | d <- ds]-    f d              = (F.ddTyCon d, dataDeclDeps dM d)--dataDeclDeps :: M.HashMap F.FTycon F.DataDecl -> F.DataDecl -> [F.FTycon]-dataDeclDeps dM = filter (`M.member` dM) . Misc.sortNub . dataDeclFTycons--dataDeclFTycons :: F.DataDecl -> [F.FTycon]-dataDeclFTycons = concatMap dataCtorFTycons . F.ddCtors--dataCtorFTycons :: F.DataCtor -> [F.FTycon]-dataCtorFTycons = concatMap dataFieldFTycons . F.dcFields--dataFieldFTycons :: F.DataField -> [F.FTycon]-dataFieldFTycons = sortFTycons . F.dfSort--sortFTycons :: Sort -> [FTycon]-sortFTycons = Vis.foldSort go []-  where-    go cs (FTC c) = c : cs-    go cs _       = cs
src/Language/Fixpoint/Smt/Serialize.hs view
@@ -22,13 +22,14 @@ import           Data.Semigroup                 (Semigroup (..)) #endif -import qualified Data.Text.Lazy.Builder         as Builder-import           Data.Text.Format+-- import           Data.Text.Format import           Language.Fixpoint.Misc (sortNub, errorstar)+import           Language.Fixpoint.Utils.Builder as Builder -- import Debug.Trace (trace)  instance SMTLIB2 (Symbol, Sort) where-  smt2 env c@(sym, t) = build "({} {})" (smt2 env sym, smt2SortMono c env t)+  smt2 env c@(sym, t) = -- build "({} {})" (smt2 env sym, smt2SortMono c env t)+                        parenSeqs [smt2 env sym, smt2SortMono c env t]  smt2SortMono, smt2SortPoly :: (PPrint a) => a -> SymEnv -> Sort -> Builder.Builder smt2SortMono = smt2Sort False@@ -41,45 +42,34 @@ smt2data env = smt2data' env . map padDataDecl  smt2data' :: SymEnv -> [DataDecl] -> Builder.Builder-smt2data' env ds = build "({}) ({})" (smt2many (smt2dataname env <$> ds), smt2many (smt2datactors env <$> ds))+smt2data' env ds = seqs [ parens $ smt2many (smt2dataname env <$> ds)+                         , parens $ smt2many (smt2datactors env <$> ds)+                         ]+   smt2dataname :: SymEnv -> DataDecl -> Builder.Builder-smt2dataname env (DDecl tc as _) = build "({} {})" (name, n)+smt2dataname env (DDecl tc as _) = parenSeqs [name, n]   where     name  = smt2 env (symbol tc)     n     = smt2 env as    smt2datactors :: SymEnv -> DataDecl -> Builder.Builder-smt2datactors env (DDecl _ as cs) = build "(par ({}) ({}))" (tvars,ds) +smt2datactors env (DDecl _ as cs) = parenSeqs ["par", parens tvars, parens ds]   where     tvars        = smt2many (smt2TV <$> [0..(as-1)])     smt2TV       = smt2 env . SVar     ds           = smt2many (smt2ctor env as <$> cs)  -{- -smt2data' :: SymEnv -> DataDecl -> Builder.Builder-smt2data' env (DDecl tc n cs) = build "({}) (({} {}))" (tvars, name, ctors)-  where-    tvars                    = smt2many (smt2TV <$> [0..(n-1)])-    name                     = smt2 env (symbol tc)-    ctors                    = smt2many (smt2ctor env <$> cs)-    smt2TV                   = smt2 env . SVar--}--{- -    (declare-datatypes (T) ((Tree leaf (node (value T) (children TreeList)))-    (TreeList nil (cons (car Tree) (cdr TreeList)))))--}- smt2ctor :: SymEnv -> Int -> DataCtor -> Builder.Builder smt2ctor env _  (DCtor c [])  = smt2 env c-smt2ctor env as (DCtor c fs)  = build "({} {})" (smt2 env c, fields)+smt2ctor env as (DCtor c fs)  = parenSeqs [smt2 env c, fields]+                                   where     fields                 = smt2many (smt2field env as <$> fs)  smt2field :: SymEnv -> Int -> DataField -> Builder.Builder-smt2field env as d@(DField x t) = build "({} {})" (smt2 env x, smt2SortPoly d env $ mkPoly as t)+smt2field env as d@(DField x t) = parenSeqs [smt2 env x, smt2SortPoly d env $ mkPoly as t]  -- | SMTLIB/Z3 don't like "unused" type variables; they get pruned away and --   cause wierd hassles. See tests/pos/adt_poly_dead.fq for an example.@@ -121,10 +111,9 @@   smt2 env = smt2 env . symbol  instance SMTLIB2 Constant where-  smt2 _ (I n)   = build "{}" (Only n)-  smt2 _ (R d)   = build "{}" (Only d)-  smt2 _ (L t _) = build "{}" (Only t)-+  smt2 _ (I n)   = bShow n+  smt2 _ (R d)   = bFloat d+  smt2 _ (L t _) = lbb t  instance SMTLIB2 Bop where   smt2 _ Plus   = "+"@@ -150,23 +139,23 @@   smt2 env (ECon c)         = smt2 env c   smt2 env (EVar x)         = smt2 env x   smt2 env e@(EApp _ _)     = smt2App env e-  smt2 env (ENeg e)         = build "(- {})" (Only $ smt2 env e)-  smt2 env (EBin o e1 e2)   = build "({} {} {})" (smt2 env o, smt2 env e1, smt2 env e2)-  smt2 env (EIte e1 e2 e3)  = build "(ite {} {} {})" (smt2 env e1, smt2 env e2, smt2 env e3)+  smt2 env (ENeg e)         = parenSeqs ["-", smt2 env e]+  smt2 env (EBin o e1 e2)   = parenSeqs [smt2 env o, smt2 env e1, smt2 env e2]+  smt2 env (EIte e1 e2 e3)  = parenSeqs ["ite", smt2 env e1, smt2 env e2, smt2 env e3]   smt2 env (ECst e t)       = smt2Cast env e t-  smt2 _   (PTrue)          = "true"-  smt2 _   (PFalse)         = "false"+  smt2 _   PTrue            = "true"+  smt2 _   PFalse           = "false"   smt2 _   (PAnd [])        = "true"-  smt2 env (PAnd ps)        = build "(and {})"   (Only $ smt2s env ps)+  smt2 env (PAnd ps)        = parenSeqs ["and", smt2s env ps]   smt2 _   (POr [])         = "false"-  smt2 env (POr ps)         = build "(or  {})"   (Only $ smt2s env ps)-  smt2 env (PNot p)         = build "(not {})"   (Only $ smt2  env p)-  smt2 env (PImp p q)       = build "(=> {} {})" (smt2 env p, smt2 env q)-  smt2 env (PIff p q)       = build "(= {} {})"  (smt2 env p, smt2 env q)+  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)    = build "(exists ({}) {})"  (smt2s env bs, 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)    = build "(forall ({}) {})"  (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@@ -189,13 +178,13 @@   | otherwise                   = smt2 env x  smtLamArg :: SymEnv -> Symbol -> Sort -> Builder.Builder-smtLamArg env x t = symbolBuilder $ symbolAtName x env () (FFunc t FInt)+smtLamArg env x t = Builder.fromText $ symbolAtName x env () (FFunc t FInt)  smt2VarAs :: SymEnv -> Symbol -> Sort -> Builder.Builder-smt2VarAs env x t = build "(as {} {})" (smt2 env x, smt2SortMono x env t)+smt2VarAs env x t = parenSeqs ["as", smt2 env x, smt2SortMono x env t]  smt2Lam :: SymEnv -> (Symbol, Sort) -> Expr -> Builder.Builder-smt2Lam env (x, xT) (ECst e eT) = build "({} {} {})" (smt2 env lambda, x', smt2 env e)+smt2Lam env (x, xT) (ECst e eT) = parenSeqs [Builder.fromText lambda, x', smt2 env e]   where     x'                          = smtLamArg env x xT     lambda                      = symbolAtName lambdaName env () (FFunc xT eT)@@ -206,19 +195,19 @@ smt2App :: SymEnv -> Expr -> Builder.Builder smt2App env e@(EApp (EApp f e1) e2)   | Just t <- unApplyAt f-  = build "({} {})" (symbolBuilder (symbolAtName applyName env e t), smt2s env [e1, e2])+  = parenSeqs [Builder.fromText (symbolAtName applyName env e t), smt2s env [e1, e2]] smt2App env e   | Just b <- Thy.smt2App smt2VarAs env f (smt2 env <$> es)   = b   | otherwise-  = build "({} {})" (smt2 env f, smt2s env es)+  = parenSeqs [smt2 env f, smt2s env es]   where     (f, es)   = splitEApp' e  smt2Coerc :: SymEnv -> Sort -> Sort -> Expr -> Builder.Builder smt2Coerc env t1 t2 e    | t1' == t2'  = smt2 env e-  | otherwise = build "({} {})" (symbolBuilder coerceFn , smt2 env e)+  | otherwise = parenSeqs [Builder.fromText coerceFn , smt2 env e]   where      coerceFn  = symbolAtName coerceName env (ECoerc t1 t2 e) t     t         = FFunc t1 t2@@ -235,34 +224,43 @@ mkRel :: SymEnv -> Brel -> Expr -> Expr -> Builder.Builder mkRel env Ne  e1 e2 = mkNe env e1 e2 mkRel env Une e1 e2 = mkNe env e1 e2-mkRel env r   e1 e2 = build "({} {} {})" (smt2 env r, smt2 env e1, smt2 env e2)+mkRel env r   e1 e2 = parenSeqs [smt2 env r, smt2 env e1, smt2 env e2]  mkNe :: SymEnv -> Expr -> Expr -> Builder.Builder-mkNe env e1 e2      = build "(not (= {} {}))" (smt2 env e1, smt2 env e2)+mkNe env e1 e2      = key "not" (parenSeqs ["=",  smt2 env e1, smt2 env e2])  instance SMTLIB2 Command where-  smt2 env (DeclData ds)       = build "(declare-datatypes {})"       (Only $ smt2data env ds)-  smt2 env (Declare x ts t)    = build "(declare-fun {} ({}) {})"     (smt2 env x, smt2many (smt2 env <$> ts), smt2 env t)-  smt2 env c@(Define t)        = build "(declare-sort {})"            (Only $ smt2SortMono c env t)-  smt2 env (Assert Nothing p)  = build "(assert {})"                  (Only $ smt2 env p)-  smt2 env (Assert (Just i) p) = build "(assert (! {} :named p-{}))"  (smt2 env p, i)+  smt2 env (DeclData ds)       = key "declare-datatypes" (smt2data env ds)+  smt2 env (Declare x ts t)    = parenSeqs ["declare-fun", Builder.fromText x, parens (smt2many (smt2 env <$> ts)), smt2 env t]+  smt2 env c@(Define t)        = key "declare-sort" (smt2SortMono c env t)+  smt2 env (DefineFunc name params rsort e) =+    let bParams = [ parenSeqs [smt2 env s, smt2 env t] | (s, t) <- params]+     in parenSeqs ["define-fun", smt2 env name, parenSeqs bParams, smt2 env rsort, smt2 env e]+  smt2 env (Assert Nothing p)  = {-# SCC "smt2-assert" #-} key "assert" (smt2 env p)+  smt2 env (Assert (Just i) p) = {-# SCC "smt2-assert" #-} key "assert" (parens ("!"<+> smt2 env p <+> ":named p-" <> bShow i))   smt2 env (Distinct az)     | length az < 2            = ""-    | otherwise                = build "(assert (distinct {}))"       (Only $ smt2s env az)-  smt2 env (AssertAx t)        = build "(assert {})"                  (Only $ smt2  env t)+    | 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 env (GetValue xs)       = "(get-value (" <> smt2s env xs <> "))"+  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)"  instance SMTLIB2 (Triggered Expr) where   smt2 env (TR NoTrigger e)       = smt2 env e   smt2 env (TR _ (PExist [] p))   = smt2 env p-  smt2 env t@(TR _ (PExist bs p)) = build "(exists ({}) (! {} :pattern({})))"  (smt2s env bs, smt2 env p, smt2s env (makeTriggers t))+  smt2 env t@(TR _ (PExist bs p)) = smtTr env "exists" bs p t   smt2 env (TR _ (PAll   [] p))   = smt2 env p-  smt2 env t@(TR _ (PAll   bs p)) = build "(forall ({}) (! {} :pattern({})))"  (smt2s env bs, smt2 env p, smt2s env (makeTriggers t))+  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))))   {-# INLINE smt2s #-} smt2s    :: SMTLIB2 a => SymEnv -> [a] -> Builder.Builder@@ -270,4 +268,4 @@  {-# INLINE smt2many #-} smt2many :: [Builder.Builder] -> Builder.Builder-smt2many = buildMany+smt2many = seqs
src/Language/Fixpoint/Smt/Theories.hs view
@@ -49,11 +49,10 @@ -- import qualified Data.HashMap.Strict      as M import           Data.Maybe (catMaybes) import qualified Data.Text.Lazy           as T-import qualified Data.Text.Lazy.Builder   as Builder-import           Data.Text.Format+-- import           Data.Text.Format import qualified Data.Text import           Data.String                 (IsString(..))-+import Language.Fixpoint.Utils.Builder  {- | [NOTE:Adding-Theories] To add new (SMTLIB supported) theories to      liquid-fixpoint and upstream, grep for "Map_default" and then add@@ -72,8 +71,9 @@ set  = "LSet" map  = "Map" -emp, 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 :: Raw emp   = "smt_set_emp"+sng   = "smt_set_sng" add   = "smt_set_add" cup   = "smt_set_cup" cap   = "smt_set_cap"@@ -123,167 +123,202 @@ string :: Raw string = strConName +bFun :: Raw -> [(Builder, Builder)] -> Builder -> Builder -> T.Text+bFun name xts out body = blt $ key "define-fun" (seqs [bb name, args, out, body])+  where+    args = parenSeqs [parens (x <+> t) | (x, t) <- xts]++bFun' :: Raw -> [Builder] -> Builder -> T.Text+bFun' name ts out = blt $ key "declare-fun" (seqs [bb name, args, out])+  where+    args = parenSeqs ts++bSort :: Raw -> Builder -> T.Text+bSort name def = blt $ key "define-sort" (bb name <+> "()" <+> def)+ z3Preamble :: Config -> [T.Text] z3Preamble u   = stringPreamble u ++-    [ format "(define-sort {} () Int)"-        (Only elt)-    , format "(define-sort {} () (Array {} Bool))"-        (set, elt)-    , format "(define-fun {} () {} ((as const {}) false))"-        (emp, set, set)-    , format "(define-fun {} ((x {}) (s {})) Bool (select s x))"-        (mem, elt, set)-    , format "(define-fun {} ((s {}) (x {})) {} (store s x true))"-        (add, set, elt, set)-    , format "(define-fun {} ((s1 {}) (s2 {})) {} ((_ map or) s1 s2))"-        (cup, set, set, set)-    , format "(define-fun {} ((s1 {}) (s2 {})) {} ((_ map and) s1 s2))"-        (cap, set, set, set)-    , format "(define-fun {} ((s {})) {} ((_ map not) s))"-        (com, set, set)-    , format "(define-fun {} ((s1 {}) (s2 {})) {} ({} s1 ({} s2)))"-        (dif, set, set, set, cap, com)-    , format "(define-fun {} ((s1 {}) (s2 {})) Bool (= {} ({} s1 s2)))"-        (sub, set, set, emp, dif)-    , format "(define-sort {} () (Array {} {}))"-        (map, elt, elt)-    , format "(define-fun {} ((m {}) (k {})) {} (select m k))"-        (sel, map, elt, elt)-    , format "(define-fun {} ((m {}) (k {}) (v {})) {} (store m k v))"-        (sto, map, elt, elt, map)-    , format "(define-fun {} ((m1 {}) (m2 {})) {} ((_ map (+ ({} {}) {})) m1 m2))"-        (mcup, map, map, map, elt, elt, elt)-    , format "(define-fun {} ((v {})) {} ((as const ({})) v))"-        (mdef, elt, map, map)-    , format "(define-fun {} ((b Bool)) Int (ite b 1 0))"-        (Only (boolToIntName :: T.Text))-    , uifDef u (symbolText mulFuncName) ("*"   :: T.Text)-    , uifDef u (symbolText divFuncName) "div"+    [ bSort elt +        "Int"+    , bSort set +        (key2 "Array" (bb elt) "Bool")+    , 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)] +        "Bool"+        "(select s x)"+    , bFun add+        [("s", bb set), ("x", bb elt)] +        (bb set)+        "(store s x true)"+    , bFun cup +        [("s1", bb set), ("s2", bb set)] +        (bb set)+        "((_ map or) s1 s2)"+    , bFun cap +        [("s1", bb set), ("s2", bb set)] +        (bb set)+        "((_ map and) s1 s2)"+    , bFun com+        [("s", bb set)] +        (bb set)+        "((_ map not) s)"+    , 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")) ++    -- Maps    +    , 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)"+    , bFun mcup+        [("m1", bb map), ("m2", bb map)]+        (bb map)+        (key2 (key "_ map" (key2 "+" (parens (bb elt <+> bb elt)) (bb elt))) "m1" "m2")+    , bFun mdef+        [("v", bb elt)]+        (bb map)+        (key (key "as const" (parens (bb map))) "v")+    , bFun boolToIntName+        [("b", "Bool")]+        "Int"+        "(ite b 1 0)"++    , uifDef u (symbolLText mulFuncName) "*" +    , uifDef u (symbolLText divFuncName) "div"     ] +symbolLText :: Symbol -> T.Text+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 -> Data.Text.Text -> T.Text -> T.Text+uifDef :: Config -> T.Text -> T.Text -> T.Text uifDef cfg f op   | linear cfg || Z3 /= solver cfg-  = format "(declare-fun {} (Int Int) Int)" (Only f)+  = bFun' f ["Int", "Int"] "Int"    | otherwise-  = format "(define-fun {} ((x Int) (y Int)) Int ({} x y))" (f, op)+  = bFun f [("x", "Int"), ("y", "Int")] "Int" (key2 (bb op) "x" "y")  cvc4Preamble :: Config -> [T.Text]-cvc4Preamble _ --TODO use uif flag u (see z3Preamble)-  = [        "(set-logic ALL_SUPPORTED)"-    , format "(define-sort {} () Int)"       (Only elt)-    , format "(define-sort {} () Int)"       (Only set)-    , format "(define-sort {} () Int)"       (Only string)-    , format "(declare-fun {} () {})"        (emp, set)-    , format "(declare-fun {} ({} {}) {})"   (add, set, elt, set)-    , format "(declare-fun {} ({} {}) {})"   (cup, set, set, set)-    , format "(declare-fun {} ({} {}) {})"   (cap, set, set, set)-    , format "(declare-fun {} ({} {}) {})"   (dif, set, set, set)-    , format "(declare-fun {} ({} {}) Bool)" (sub, set, set)-    , format "(declare-fun {} ({} {}) Bool)" (mem, elt, set)-    , format "(define-sort {} () (Array {} {}))"-        (map, elt, elt)-    , format "(define-fun {} ((m {}) (k {})) {} (select m k))"-        (sel, map, elt, elt)-    , format "(define-fun {} ((m {}) (k {}) (v {})) {} (store m k v))"-        (sto, map, elt, elt, map)-    , format "(define-fun {} ((b Bool)) Int (ite b 1 0))"-        (Only (boolToIntName :: Raw))+cvc4Preamble z+  = [        "(set-logic ALL_SUPPORTED)"]+  ++ commonPreamble z+  ++ cvc4MapPreamble z++commonPreamble :: Config -> [T.Text]+commonPreamble _ --TODO use uif flag u (see z3Preamble)+  = [ bSort elt    "Int"+    , bSort set    "Int"+    , bSort string "Int"+    , 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)+    , bFun' cap [bb set, bb set] (bb set)+    , bFun' dif [bb set, bb set] (bb set)+    , bFun' sub [bb set, bb set] "Bool"+    , bFun' mem [bb elt, bb set] "Bool"+    , bFun boolToIntName [("b", "Bool")] "Int" "(ite b 1 0)"     ] -smtlibPreamble :: Config -> [T.Text]-smtlibPreamble _ --TODO use uif flag u (see z3Preamble)-  = [       --  "(set-logic QF_AUFRIA)",-      format "(define-sort {} () Int)"       (Only elt)-    , format "(define-sort {} () Int)"       (Only set)-    , format "(declare-fun {} () {})"        (emp, set)-    , format "(declare-fun {} ({} {}) {})"   (add, set, elt, set)-    , format "(declare-fun {} ({} {}) {})"   (cup, set, set, set)-    , format "(declare-fun {} ({} {}) {})"   (cap, set, set, set)-    , format "(declare-fun {} ({} {}) {})"   (dif, set, set, set)-    , format "(declare-fun {} ({} {}) Bool)" (sub, set, set)-    , format "(declare-fun {} ({} {}) Bool)" (mem, elt, set)-    , format "(define-sort {} () Int)"       (Only map)-    , format "(declare-fun {} ({} {}) {})"    (sel, map, elt, elt)-    , format "(declare-fun {} ({} {} {}) {})" (sto, map, elt, elt, map)-    , format "(declare-fun {} ({} {} {}) {})" (sto, map, elt, elt, map)-    , format "(define-fun {} ((b Bool)) Int (ite b 1 0))" (Only (boolToIntName :: Raw))+cvc4MapPreamble :: Config -> [T.Text]+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)"     ] +smtlibPreamble :: Config -> [T.Text]+smtlibPreamble z --TODO use uif flag u (see z3Preamble)+  = commonPreamble z + ++ [ bSort map "Int"+    , bFun' sel [bb map, bb elt] (bb elt)+    , bFun' sto [bb map, bb elt, bb elt] (bb map)+    ]  stringPreamble :: Config -> [T.Text] stringPreamble cfg | stringTheory cfg-  = [-      format "(define-sort {} () String)" (Only string)-    , format "(define-fun {} ((s {})) Int ({} s))"-        (strLen :: Raw, string, z3strlen)-    , format "(define-fun {} ((s {}) (i Int) (j Int)) {} ({} s i j))"-        (strSubstr :: Raw, string, string, z3strsubstr)-    , format "(define-fun {} ((x {}) (y {})) {} ({} x y))"-        (strConcat :: Raw, string, string, string, z3strconcat)+  = [ 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")     ]+ stringPreamble _-  = [-      format "(define-sort {} () Int)" (Only string)-    , format "(declare-fun {} ({}) Int)"-        (strLen :: Raw, string)-    , format "(declare-fun {} ({} Int Int) {})"-        (strSubstr :: Raw, string, string)-    , format "(declare-fun {} ({} {}) {})"-        (strConcat :: Raw, string, string, string)+  = [ bSort string "Int"+    , bFun' strLen [bb string] "Int" +    , bFun' strSubstr [bb string, "Int", "Int"] (bb string)+    , bFun' strConcat [bb string, bb string] (bb string)     ] -- -------------------------------------------------------------------------------- -- | Exported API -------------------------------------------------------------- ---------------------------------------------------------------------------------smt2Symbol :: SymEnv -> Symbol -> Maybe Builder.Builder-smt2Symbol env x = Builder.fromLazyText . tsRaw <$> symEnvTheory x env+smt2Symbol :: SymEnv -> Symbol -> Maybe Builder+smt2Symbol env x = fromLazyText . tsRaw <$> symEnvTheory x env  instance SMTLIB2 SmtSort where   smt2 _ = smt2SmtSort -smt2SmtSort :: SmtSort -> Builder.Builder+smt2SmtSort :: SmtSort -> Builder smt2SmtSort SInt         = "Int" smt2SmtSort SReal        = "Real" smt2SmtSort SBool        = "Bool"-smt2SmtSort SString      = build "{}" (Only string)-smt2SmtSort SSet         = build "{}" (Only set)-smt2SmtSort SMap         = build "{}" (Only map)-smt2SmtSort (SBitVec n)  = build "(_ BitVec {})" (Only n)-smt2SmtSort (SVar n)     = build "T{}" (Only n)+smt2SmtSort SString      = bb string+smt2SmtSort SSet         = bb set+smt2SmtSort SMap         = bb map+smt2SmtSort (SBitVec n)  = key "_ BitVec" (bShow n)+smt2SmtSort (SVar n)     = "T" <> bShow n smt2SmtSort (SData c []) = symbolBuilder c-smt2SmtSort (SData c ts) = build "({} {})" (symbolBuilder c        , smt2SmtSorts ts)+smt2SmtSort (SData c ts) = parenSeqs [symbolBuilder c, smt2SmtSorts ts]+ -- smt2SmtSort (SApp ts)    = build "({} {})" (symbolBuilder tyAppName, smt2SmtSorts ts) -smt2SmtSorts :: [SmtSort] -> Builder.Builder-smt2SmtSorts = buildMany . fmap smt2SmtSort+smt2SmtSorts :: [SmtSort] -> Builder+smt2SmtSorts = seqs . fmap smt2SmtSort -type VarAs = SymEnv -> Symbol -> Sort -> Builder.Builder+type VarAs = SymEnv -> Symbol -> Sort -> Builder ---------------------------------------------------------------------------------smt2App :: VarAs -> SymEnv -> Expr -> [Builder.Builder] -> Maybe Builder.Builder+smt2App :: VarAs -> SymEnv -> Expr -> [Builder] -> Maybe Builder -------------------------------------------------------------------------------- smt2App _ _ (ECst (EVar f) _) [d]-  | f == setEmpty = Just $ build "{}"             (Only emp)-  | f == setEmp   = Just $ build "(= {} {})"      (emp, d)-  | f == setSng   = Just $ build "({} {} {})"     (add, emp, 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)  smt2App k env f (d:ds)   | Just fb <- smt2AppArg k env f-  = Just $ build "({} {})" (fb, d <> mconcat [ " " <> d | d <- ds])+  = Just $ key fb (d <> mconcat [ " " <> d | d <- ds])  smt2App _ _ _ _    = Nothing -smt2AppArg :: VarAs -> SymEnv -> Expr -> Maybe Builder.Builder+smt2AppArg :: VarAs -> SymEnv -> Expr -> Maybe Builder smt2AppArg k env (ECst (EVar f) t)   | Just fThy <- symEnvTheory f env   = Just $ if isPolyCtor fThy t             then (k env f (ffuncOut t))-            else (build "{}" (Only (tsRaw fThy)))+            else bb (tsRaw fThy)  smt2AppArg _ _ _   = Nothing@@ -306,8 +341,8 @@  thyAppInfo :: TheorySymbol -> Maybe Int thyAppInfo ti = case tsInterp ti of-  Field -> Just 1-  _     -> sortAppInfo (tsSort ti)+  Field    -> Just 1+  _        -> sortAppInfo (tsSort ti)  sortAppInfo :: Sort -> Maybe Int sortAppInfo t = case bkFFunc t of@@ -332,12 +367,14 @@                                   interpSymbols                                ++ concatMap dataDeclSymbols ds + -------------------------------------------------------------------------------- interpSymbols :: [(Symbol, TheorySymbol)] -------------------------------------------------------------------------------- interpSymbols =   [ interpSym setEmp   emp  (FAbs 0 $ FFunc (setSort $ FVar 0) boolSort)   , interpSym setEmpty emp  (FAbs 0 $ FFunc intSort (setSort $ FVar 0))+  , interpSym setSng   sng  (FAbs 0 $ FFunc (FVar 0) (setSort $ FVar 0))   , interpSym setAdd   add   setAddSort   , interpSym setCup   cup   setBopSort   , interpSym setCap   cap   setBopSort@@ -375,7 +412,6 @@                                          (mapSort (FVar 0) (FVar 1))      bvBopSort  = FFunc bitVecSort $ FFunc bitVecSort bitVecSort-  interpSym :: Symbol -> Raw -> Sort -> (Symbol, TheorySymbol) interpSym x n t = (x, Thy x n t Theory)
src/Language/Fixpoint/Smt/Types.hs view
@@ -26,9 +26,11 @@      ) where +import           Control.Concurrent.Async (Async)+import           Control.Concurrent.STM (TVar) import           Language.Fixpoint.Types+import           Language.Fixpoint.Utils.Builder (Builder) import qualified Data.Text                as T-import qualified Data.Text.Lazy.Builder   as LT import           Text.PrettyPrint.HughesPJ  import           System.IO                (Handle)@@ -45,10 +47,13 @@ -- | Commands issued to SMT engine data Command      = Push                   | Pop+                  | Exit+                  | SetMbqi                   | CheckSat                   | DeclData ![DataDecl]-                  | Declare  !Symbol [SmtSort] !SmtSort+                  | Declare  T.Text [SmtSort] !SmtSort                   | Define   !Sort+                  | DefineFunc Symbol [(Symbol, SmtSort)] !SmtSort Expr                   | Assert   !(Maybe Int) !Expr                   | AssertAx !(Triggered Expr)                   | Distinct [Expr] -- {v:[Expr] | 2 <= len v}@@ -60,13 +65,17 @@   pprintTidy _ = ppCmd  ppCmd :: Command -> Doc+ppCmd Exit             = text "Exit"+ppCmd SetMbqi          = text "SetMbqi" ppCmd Push             = text "Push" ppCmd Pop              = text "Pop" ppCmd CheckSat         = text "CheckSat" ppCmd (DeclData d)     = text "Data" <+> pprint d-ppCmd (Declare x [] t) = text "Declare" <+> pprint x <+> text ":" <+> pprint t-ppCmd (Declare x ts t) = text "Declare" <+> pprint x <+> text ":" <+> parens (pprint ts) <+> pprint t +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 (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 ..."@@ -90,6 +99,10 @@   , 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   }  --------------------------------------------------------------------------------@@ -97,7 +110,7 @@ --------------------------------------------------------------------------------  class SMTLIB2 a where-  smt2 :: SymEnv -> a -> LT.Builder+  smt2 :: SymEnv -> a -> Builder -runSmt2 :: (SMTLIB2 a) => SymEnv -> a -> LT.Builder+runSmt2 :: (SMTLIB2 a) => SymEnv -> a -> Builder runSmt2 = smt2
src/Language/Fixpoint/Solver.hs view
@@ -2,7 +2,11 @@ --   In particular it exports the functions that solve constraints supplied --   either as .fq files or as FInfo. {-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DoAndIfThenElse     #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}  module Language.Fixpoint.Solver (     -- * Invoke Solver on an FInfo@@ -22,19 +26,25 @@   , simplifyFInfo ) where -import           Control.Concurrent-import           Data.Binary+import           Control.Concurrent                 (setNumCapabilities)+import qualified Data.HashMap.Strict              as HashMap+import qualified Data.Store                       as S+import           Data.Aeson                         (ToJSON, encode)+import qualified Data.Text.Lazy.IO                as LT+import qualified Data.Text.Lazy.Encoding          as LT import           System.Exit                        (ExitCode (..)) import           System.Console.CmdArgs.Verbosity   (whenNormal, whenLoud) import           Text.PrettyPrint.HughesPJ          (render) import           Control.Monad                      (when) import           Control.Exception                  (catch)-+import           Language.Fixpoint.Solver.EnvironmentReduction+  (reduceEnvironments, simplifyBindings) import           Language.Fixpoint.Solver.Sanitize  (symbolEnv, sanitize) import           Language.Fixpoint.Solver.UniqifyBinds (renameAll) import           Language.Fixpoint.Defunctionalize (defunctionalize)-import           Language.Fixpoint.SortCheck            (Elaborate (..))+import           Language.Fixpoint.SortCheck            (Elaborate (..), unElab) import           Language.Fixpoint.Solver.Extensionality (expand)+import           Language.Fixpoint.Solver.Prettify (savePrettifiedQuery) import           Language.Fixpoint.Solver.UniqifyKVars (wfcUniqify) import qualified Language.Fixpoint.Solver.Solve     as Sol import           Language.Fixpoint.Types.Config@@ -48,6 +58,7 @@ import           Language.Fixpoint.Minimize (minQuery, minQuals, minKvars) import           Language.Fixpoint.Solver.Instantiate (instantiate) import           Control.DeepSeq+import qualified Data.ByteString as B  --------------------------------------------------------------------------- -- | Solve an .fq file ----------------------------------------------------@@ -58,19 +69,20 @@     cfg'       <- withPragmas cfg opts     let fi'     = ignoreQualifiers cfg' fi     r          <- solve cfg' fi'-    resultExitCode (fst <$> r)+    resultExitCode cfg (fst <$> r)   where     file    = srcFile      cfg  ----------------------------------------------------------------------------resultExitCode :: Result SubcId -> IO ExitCode +resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a +               -> IO ExitCode ----------------------------------------------------------------------------resultExitCode r = do -  -- let str  = render $ resultDoc $!! (const () <$> stat)-  -- putStrLn "\n"+resultExitCode cfg r = do    whenNormal $ colorStrLn (colorResult stat) (statStr $!! stat)+  when (json cfg) $ LT.putStrLn jStr   return (eCode r)   where +    jStr    = LT.decodeUtf8 . encode $ r     stat    = resStatus $!! r     eCode   = resultExit . resStatus     statStr = render . resultDoc @@ -114,11 +126,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" #-} decodeFile file+readBinFq file = {-# SCC "parseBFq" #-} do +  bs <- B.readFile file+  case S.decode bs of +    Right fi -> return fi+    Left err -> error ("Error decoding .bfq: " ++ show err)   -------------------------------------------------------------------------------- -- | Solve in parallel after partitioning an FInfo to indepdendant parts@@ -159,6 +175,7 @@    rs <- asyncMapM f xs    return $ mconcat rs + -------------------------------------------------------------------------------- -- | Native Haskell Solver ----------------------------------------------------- --------------------------------------------------------------------------------@@ -169,7 +186,7 @@                              (return . result)  result :: Error -> Result a-result e = Result (Crash [] msg) mempty mempty+result e = Result (Crash [] msg) mempty mempty mempty   where     msg  = showpp e @@ -178,6 +195,7 @@   where     msg           = "fq file after Uniqify & Rename " ++ show i ++ "\n" +{-# SCC simplifyFInfo #-} simplifyFInfo :: (NFData a, Fixpoint a, Show a, Loc a)                => Config -> FInfo a -> IO (SInfo a) simplifyFInfo !cfg !fi0 = do@@ -186,34 +204,47 @@   -- let qs   = quals fi0   -- whenLoud $ print qs   -- whenLoud $ putStrLn $ showFix (quals fi1)-  let fi1   = fi0 { quals = remakeQual <$> quals fi0 }-  let si0   = {-# SCC "convertFormat" #-} convertFormat fi1+  reducedFi <- reduceFInfo cfg fi0+  let fi1   = reducedFi { quals = remakeQual <$> 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-  instantiate cfg $!! si6+  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+  when (save cfg) $+    savePrettifiedQuery cfg reducedFi+  if noEnvironmentReduction cfg then+    return fi+  else+    return reducedFi  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-  -- when (save cfg) $ saveSolution cfg+  -- saveSolution cfg res+  when (save cfg) $ saveSolution cfg res   -- writeLoud $ "\nSolution:\n"  ++ showpp (resSolution res)   -- colorStrLn (colorResult stat) (show stat)   return res@@ -238,5 +269,17 @@   let f = queryFile Out cfg   putStrLn $ "Saving Solution: " ++ f ++ "\n"   ensurePath f-  writeFile f $ "\nSolution:\n" ++ showpp (resSolution  res)-                ++ (if (gradual cfg) then ("\n\n" ++ showpp (gresSolution res)) else mempty)+  writeFile f $ unlines $+    [ ""+    , "Solution:"+    , showpp (resSolution  res)+    ] +++    ( if gradual cfg then ["", "", showpp (gresSolution res)]+      else []+    ) +++    [ ""+    , ""+    , "Non-cut kvars:"+    , ""+    , showpp (HashMap.map unElab $ resNonCutsSolution res)+    ]
src/Language/Fixpoint/Solver/Eliminate.hs view
@@ -13,7 +13,7 @@ import           Language.Fixpoint.Types.Config    (Config) import qualified Language.Fixpoint.Types.Solutions as Sol import           Language.Fixpoint.Types-import           Language.Fixpoint.Types.Visitor   (kvars, isConcC)+import           Language.Fixpoint.Types.Visitor   (kvarsExpr, isConcC) import           Language.Fixpoint.Graph import           Language.Fixpoint.Misc            (safeLookup, group, errorstar) import           Language.Fixpoint.Solver.Sanitize@@ -22,6 +22,7 @@ -- | `solverInfo` constructs a `SolverInfo` comprising the Solution and various --   indices needed by the worklist-based refinement loop --------------------------------------------------------------------------------+{-# SCC solverInfo #-} solverInfo :: Config -> SInfo a -> SolverInfo a b -------------------------------------------------------------------------------- solverInfo cfg sI = SI sHyp sI' cD cKs@@ -71,7 +72,7 @@ kIndex si  = group [(k, i) | (i, c) <- iCs, k <- rkvars c]   where     iCs    = M.toList (cm si)-    rkvars = kvars . crhs+    rkvars = kvarsExpr . crhs  nonCutHyps :: SInfo a -> KIndex -> S.HashSet KVar -> [(KVar, Sol.Hyp)] nonCutHyps si kI nKs = [ (k, nonCutHyp kI si k) | k <- S.toList nKs ]
+ src/Language/Fixpoint/Solver/EnvironmentReduction.hs view
@@ -0,0 +1,752 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Functions to make environments smaller+module Language.Fixpoint.Solver.EnvironmentReduction+  ( reduceEnvironments+  , simplifyBindings+  , dropLikelyIrrelevantBindings+  , inlineInSortedReft+  , mergeDuplicatedBindings+  , simplifyBooleanRefts+  , undoANF+  ) where++import           Control.Monad (guard, mplus, msum)+import           Data.Char (isUpper)+import           Data.Hashable (Hashable)+import           Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashMap.Strict as HashMap.Strict+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import           Data.List (foldl', nub, partition)+import           Data.Maybe (fromMaybe)+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.Types.Config+import           Language.Fixpoint.Types.Constraints+import           Language.Fixpoint.Types.Environments+  ( BindEnv+  , BindId+  , IBindEnv+  , beBinds+  , diffIBindEnv+  , elemsIBindEnv+  , emptyIBindEnv+  , filterIBindEnv+  , fromListIBindEnv+  , insertsIBindEnv+  , insertBindEnv+  , lookupBindEnv+  , memberIBindEnv+  , unionIBindEnv+  , unionsIBindEnv+  )+import           Language.Fixpoint.Types.Names+  ( Symbol+  , anfPrefix+  , isPrefixOfSym+  , prefixOfSym+  , symbolText+  )+import           Language.Fixpoint.Types.PrettyPrint+import           Language.Fixpoint.Types.Refinements+  ( Brel(..)+  , Expr(..)+  , KVar(..)+  , SortedReft(..)+  , Subst(..)+  , pattern PTrue+  , pattern PFalse+  , expr+  , exprKVars+  , exprSymbolsSet+  , mapPredReft+  , pAnd+  , reft+  , reftBind+  , reftPred+  , sortedReftSymbols+  , subst1+  )+import           Language.Fixpoint.Types.Sorts (boolSort, sortSymbols)+import           Language.Fixpoint.Types.Visitor (mapExprOnExpr)++-- | Strips from all the constraint environments the bindings that are+-- irrelevant for their respective constraints.+--+-- Environment reduction has the following stages.+--+-- Stage 1)+-- Compute the binding dependencies of each constraint ignoring KVars.+--+-- A binding is a dependency of a constraint if it is mentioned in the lhs, or+-- the rhs of the constraint, or in a binding that is a dependency, or in a+-- @define@ or @match@ clause that is mentioned in the lhs or rhs or another+-- binding dependency, or if it appears in the environment of the constraint and+-- can't be discarded as trivial (see 'dropIrrelevantBindings').+--+-- Stage 2)+-- Compute the binding dependencies of KVars.+--+-- A binding is a dependency of a KVar K1 if it is a dependency of a constraint+-- in which the K1 appears, or if it is a dependency of another KVar appearing+-- in a constraint in which K1 appears.+--+-- Stage 3)+-- Drop from the environment of each constraint the bindings that aren't+-- dependencies of the constraint, or that aren't dependencies of any KVar+-- appearing in the constraint.+--+--+-- Note on SInfo:+--+-- This function can be changed to work on 'SInfo' rather than 'FInfo'. However,+-- this causes some tests to fail. At least:+--+--    liquid-fixpoint/tests/proof/rewrite.fq+--    tests/import/client/ReflectClient4a.hs+--+-- lhs bindings are numbered with the highest numbers when FInfo+-- is converted to SInfo. Environment reduction, however, rehashes+-- the binding identifiers and lhss could end up with a lower numbering.+-- For most of the tests, this doesn't seem to make a difference, but it+-- causes the two tests referred above to fail.+--+-- See #473 for more discussion.+--+reduceEnvironments :: FInfo a -> FInfo a+reduceEnvironments fi =+  let constraints = HashMap.Strict.toList $ cm fi+      aenvMap = axiomEnvSymbols (ae fi)+      reducedEnvs = map (reduceConstraintEnvironment (bs fi) aenvMap) constraints+      (cm', ws') = reduceWFConstraintEnvironments (bs fi) (reducedEnvs, ws fi)+      bs' = (bs fi) { beBinds = dropBindsMissingFrom (beBinds $ bs fi) cm' ws' }++   in fi+     { bs = bs'+     , cm = HashMap.fromList cm'+     , ws = ws'+     , ebinds = updateEbinds bs' (ebinds fi)+     , bindInfo = updateBindInfoKeys bs' $ bindInfo fi+     }++  where+    dropBindsMissingFrom+      :: HashMap BindId (Symbol, SortedReft)+      -> [(SubcId, SubC a)]+      -> HashMap KVar (WfC a)+      -> HashMap BindId (Symbol, SortedReft)+    dropBindsMissingFrom be cs ws =+      let ibindEnv = unionsIBindEnv $+            map (senv . snd) cs +++            map wenv (HashMap.elems ws)+       in+          HashMap.filterWithKey (\bId _ -> memberIBindEnv bId ibindEnv) be++    -- Updates BindIds in an ebinds list+    updateEbinds be = filter (`HashMap.member` beBinds be)++    -- Updates BindId keys in a bindInfos map+    updateBindInfoKeys be oldBindInfos =+      HashMap.intersection oldBindInfos (beBinds be)++-- | Reduces the environments of WF constraints.+--+-- @reduceWFConstraintEnvironments bindEnv (cs, ws)@+--  * enlarges the environments in cs with bindings needed by the kvars they use+--  * replaces the environment in ws with reduced environments+--+-- Reduction of wf environments gets rid of any bindings not mentioned by+-- 'relatedKVarBinds' or any substitution on the corresponding KVar anywhere.+--+reduceWFConstraintEnvironments+  :: BindEnv    -- ^ Environment before reduction+  -> ([ReducedConstraint a], HashMap KVar (WfC a))+     -- ^ @(cs, ws)@:+     --  * @cs@ are the constraints with reduced environments+     --  * @ws@ are the wf constraints in which to reduce environments+  -> ([(SubcId, SubC a)], HashMap KVar (WfC a))+reduceWFConstraintEnvironments bindEnv (cs, wfs) =+  let+      (kvarsBinds, kvarSubstSymbols, kvarsBySubC) = relatedKVarBinds bindEnv cs++      wfBindsPlusSortSymbols =+        HashMap.unionWith HashSet.union kvarsBinds $+        HashMap.map (sortSymbols . (\(_, b, _) -> b) . wrft) wfs++      kvarsRelevantBinds =+        HashMap.unionWith HashSet.union wfBindsPlusSortSymbols $+        kvarSubstSymbols++      ws' =+        HashMap.mapWithKey+          (reduceWFConstraintEnvironment bindEnv kvarsRelevantBinds)+          wfs++      wsSymbols = HashMap.map (asSymbolSet bindEnv . wenv) ws'++      kvarsWsBinds =+        HashMap.unionWith HashSet.intersection wfBindsPlusSortSymbols wsSymbols++      cs' = zipWith+              (updateSubcEnvsWithKVarBinds bindEnv kvarsWsBinds)+              kvarsBySubC+              cs+   in+      (cs', ws')++  where+    -- Initially, the constraint environment only includes the information+    -- relevant to the rhs and the lhs. If a kvar is present, it may need+    -- additional bindings that are required by the kvar. These are added+    -- in this function.+    updateSubcEnvsWithKVarBinds+      :: BindEnv+      -> HashMap KVar (HashSet Symbol)+      -> [KVar]+      -> ReducedConstraint a+      -> (SubcId, SubC a)+    updateSubcEnvsWithKVarBinds be kvarsBinds kvs c =+      let updateIBindEnv oldEnv =+            unionIBindEnv (reducedEnv c) $+            if null kvs then emptyIBindEnv+            else fromListIBindEnv+              [ bId+              | bId <- elemsIBindEnv oldEnv+              , let (s, _sr) = lookupBindEnv bId be+              , any (neededByKVar s) kvs+              ]+          neededByKVar s kv =+            case HashMap.lookup kv kvarsBinds of+              Nothing -> False+              Just kbindSyms -> HashSet.member s kbindSyms+       in (constraintId c, updateSEnv (originalConstraint c) updateIBindEnv)++    -- @reduceWFConstraintEnvironment be kbinds k c@ drops bindings from @c@+    -- that aren't present in @kbinds ! k@.+    reduceWFConstraintEnvironment+      :: BindEnv+      -> HashMap KVar (HashSet Symbol)+      -> KVar+      -> WfC a+      -> WfC a+    reduceWFConstraintEnvironment bindEnv kvarBinds k c =+      case HashMap.lookup k kvarBinds of+        Nothing -> c { wenv = emptyIBindEnv }+        Just kbindSymbols ->+          c { wenv = filterIBindEnv (relevantBindIds kbindSymbols) (wenv c) }+      where+        relevantBindIds :: HashSet Symbol -> BindId -> Bool+        relevantBindIds kbindSymbols bId =+          let (s, _) = lookupBindEnv bId bindEnv+           in HashSet.member s kbindSymbols++data ReducedConstraint a = ReducedConstraint+  { reducedEnv :: IBindEnv       -- ^ Environment which has been reduced+  , originalConstraint :: SubC a -- ^ The original constraint+  , constraintId :: SubcId       -- ^ Id of the constraint+  }++reduceConstraintEnvironment+  :: BindEnv+  -> HashMap Symbol (HashSet Symbol)+  -> (SubcId, SubC a)+  -> ReducedConstraint a+reduceConstraintEnvironment bindEnv aenvMap (cid, c) =+  let env = [ (s, bId, sr)+            | bId <- elemsIBindEnv $ senv c+            , let (s, sr) = lookupBindEnv bId bindEnv+            ]+      prunedEnv =+        fromListIBindEnv+        [ bId | (_, bId, _) <- dropIrrelevantBindings aenvMap constraintSymbols env ]+      constraintSymbols =+        HashSet.union (sortedReftSymbols $ slhs c) (sortedReftSymbols $ srhs c)+   in ReducedConstraint+        { reducedEnv = prunedEnv+        , originalConstraint = c+        , constraintId = cid+        }++-- | @dropIrrelevantBindings aenvMap ss env@ drops bindings from @env@ which+-- aren't referenced neither in a refinement type in the environment nor in+-- @ss@, and not reachable in definitions of @aenv@ referred from @env@ or+-- @ss@, and which can't possibly affect the outcome of verification.+--+-- Right now, it drops bindings of the form @a : {v | true }@ and+-- @b : {v | v [>=|<=|=|!=|etc] e }@+-- whenever @a@ and @b@ aren't referenced from any formulas.+--+dropIrrelevantBindings+  :: HashMap Symbol (HashSet Symbol)+  -> HashSet Symbol+  -> [(Symbol, BindId, SortedReft)]+  -> [(Symbol, BindId, SortedReft)]+dropIrrelevantBindings aenvMap extraSymbols env =+  filter relevantBind env+  where+    allSymbols =+      reachableSymbols (HashSet.union extraSymbols envSymbols) aenvMap+    envSymbols =+      HashSet.unions $ map (\(_, _, sr) -> sortedReftSymbols sr) env++    relevantBind (s, _, sr)+      | HashSet.member s allSymbols = True+      | otherwise = case reftPred (sr_reft sr) of+          PTrue -> False+          PAtom _ (dropECst -> EVar sym) _e -> sym /= reftBind (sr_reft sr)+          PAtom _ _e (dropECst -> EVar sym) -> sym /= reftBind (sr_reft sr)+          _ -> True++-- | For each Equation and Rewrite, collects the symbols that it needs.+axiomEnvSymbols :: AxiomEnv -> HashMap Symbol (HashSet Symbol)+axiomEnvSymbols ae =+  HashMap.union+    (HashMap.fromList $ map eqSymbols $ aenvEqs ae)+    (HashMap.fromList $ map rewriteSymbols $ aenvSimpl ae)+  where+    eqSymbols eq =+      let bodySymbols =+            HashSet.difference+              (exprSymbolsSet (eqBody eq) `HashSet.union` sortSymbols (eqSort eq))+              (HashSet.fromList $ map fst $ eqArgs eq)+          sortSyms = HashSet.unions $ map (sortSymbols . snd) $ eqArgs eq+          allSymbols =+            if eqRec eq then+              HashSet.insert (eqName eq) (bodySymbols `HashSet.union` sortSyms)+            else+              bodySymbols `HashSet.union` sortSyms+       in+          (eqName eq, allSymbols)++    rewriteSymbols rw =+      let bodySymbols =+            HashSet.difference+              (exprSymbolsSet (smBody rw))+              (HashSet.fromList $ smArgs rw)+          rwSymbols = HashSet.insert (smDC rw) bodySymbols+       in (smName rw, rwSymbols)++unconsHashSet :: (Hashable a, Eq a) => HashSet a -> Maybe (a, HashSet a)+unconsHashSet xs = case HashSet.toList xs of+  [] -> Nothing+  (x : _) -> Just (x, HashSet.delete x xs)++setOf :: (Hashable k, Eq k) => HashMap k (HashSet a) -> k -> HashSet a+setOf m x = fromMaybe HashSet.empty (HashMap.lookup x m)++mapOf :: (Hashable k, Eq k) => HashMap k (HashMap a b) -> k -> HashMap a b+mapOf m x = fromMaybe HashMap.empty (HashMap.lookup x m)++-- @relatedKVarBinds binds cs@ yields:+-- 1) the set of all bindings that might be needed by each KVar mentioned+-- in the constraints @cs@, and+-- 2) the set of symbols appearing in substitutions of the KVar in any+-- constraint. That is: @kv@ is associated with @i@, @j@, and @h@ if there+-- is some constraint with the KVar substitution @kv[i:=e0][j:=e1]@ and+-- some constraint with the KVar substitution @kv[h:=e2]@ appearing in+-- the rhs, lhs, or the environment.+-- 3) The list of kvars used in each constraint.+--+-- We assume that if a KVar is mentioned in a constraint or in its+-- environment, then all the bindings in the environment of the constraint+-- might be needed by the KVar.+--+-- Moreover, if two KVars are mentioned together in the same constraint,+-- then the bindings that might be needed for either of them might+-- be needed by the other.+--+relatedKVarBinds+  :: BindEnv+  -> [ReducedConstraint a]+  -> (HashMap KVar (HashSet Symbol), HashMap KVar (HashSet Symbol), [[KVar]])+relatedKVarBinds bindEnv cs =+  let kvarsSubstSymbolsBySubC = map kvarBindsFromSubC cs+      kvarsBySubC = map HashMap.keys kvarsSubstSymbolsBySubC+      bindIdsByKVar =+       ShareMap.toHashMap $+       ShareMap.map (asSymbolSet bindEnv) $+       groupIBindEnvByKVar $ zip (map reducedEnv cs) kvarsBySubC+      substsByKVar =+        foldl' (HashMap.unionWith HashSet.union) HashMap.empty kvarsSubstSymbolsBySubC+   in+      (bindIdsByKVar, substsByKVar, kvarsBySubC)+  where+    kvarsByBindId :: HashMap BindId (HashMap KVar [Subst])+    kvarsByBindId =+      HashMap.map (exprKVars . reftPred . sr_reft . snd) $ beBinds bindEnv++    -- Returns all of the KVars used in the constraint, together with+    -- the symbols that appear in substitutions of those KVars.+    kvarBindsFromSubC :: ReducedConstraint a -> HashMap KVar (HashSet Symbol)+    kvarBindsFromSubC sc =+      let c = originalConstraint sc+          unSubst (Su su) = su+          substsToHashSet =+            HashSet.fromMap . HashMap.map (const ()) . HashMap.unions . map unSubst+       in foldl' (HashMap.unionWith HashSet.union) HashMap.empty $+          map (HashMap.map substsToHashSet) $+          (exprKVars (reftPred $ sr_reft $ srhs c) :) $+          (exprKVars (reftPred $ sr_reft $ slhs c) :) $+          map (mapOf kvarsByBindId) $+          elemsIBindEnv (reducedEnv sc)++    -- @groupIBindEnvByKVar kvs@ is a map of KVars to all the bindings that+    -- they can potentially use.+    --+    -- @kvars@ tells for each environment what KVars it uses.+    groupIBindEnvByKVar :: [(IBindEnv, [KVar])] -> ShareMap KVar IBindEnv+    groupIBindEnvByKVar = foldl' mergeBinds ShareMap.empty++    -- @mergeBinds sm bs (bindIds, kvars)@ merges the binds used by all KVars in+    -- @kvars@ and also adds to the result the bind Ids in @bindIds@.+    mergeBinds+      :: ShareMap KVar IBindEnv+      -> (IBindEnv, [KVar])+      -> ShareMap KVar IBindEnv+    mergeBinds sm (bindIds, kvars) = case kvars of+      [] -> sm+      k : ks ->+        let sm' = ShareMap.insertWith unionIBindEnv k bindIds sm+         in foldr (ShareMap.mergeKeysWith unionIBindEnv k) sm' ks++asSymbolSet :: BindEnv -> IBindEnv -> HashSet Symbol+asSymbolSet be ibinds =+  HashSet.fromList+    [ s+    | bId <- elemsIBindEnv ibinds+    , let (s, _) = lookupBindEnv bId be+    ]++-- | @reachableSymbols x r@ computes the set of symbols reachable from @x@+-- in the graph represented by @r@. Includes @x@ in the result.+reachableSymbols :: HashSet Symbol -> HashMap Symbol (HashSet Symbol) -> HashSet Symbol+reachableSymbols ss0 outgoingEdges = go HashSet.empty ss0+  where+    -- @go acc ss@ contains @acc@ and @ss@ plus any symbols reachable from @ss@+    go :: HashSet Symbol -> HashSet Symbol -> HashSet Symbol+    go acc ss = case unconsHashSet ss of+      Nothing -> acc+      Just (x, xs) ->+        if x `HashSet.member` acc then go acc xs+        else+          let relatedToX = setOf outgoingEdges x+           in go (HashSet.insert x acc) (HashSet.union relatedToX xs)++-- | Simplifies bindings in constraint environments.+--+-- It runs 'mergeDuplicatedBindings' and 'simplifyBooleanRefts'+-- on the environment of each constraint.+--+-- If 'inlineANFBindings cfg' is on, also runs 'undoANF' to inline+-- @lq_anf@ bindings.+simplifyBindings :: Config -> FInfo a -> FInfo a+simplifyBindings cfg fi =+  let (bs', cm', oldToNew) = simplifyConstraints (bs fi) (cm fi)+   in fi+        { bs = bs'+        , cm = cm'+        , ebinds = updateEbinds oldToNew (ebinds fi)+        , bindInfo = updateBindInfoKeys oldToNew $ bindInfo fi+        }+  where+    updateEbinds :: HashMap BindId [BindId] -> [BindId] -> [BindId]+    updateEbinds oldToNew ebs =+      nub $+      concat [ bId : fromMaybe [] (HashMap.lookup bId oldToNew) | bId <- ebs ]++    updateBindInfoKeys+      :: HashMap BindId [BindId] -> HashMap BindId a -> HashMap BindId a+    updateBindInfoKeys oldToNew infoMap =+      HashMap.fromList+        [ (n, a)+        | (bId, a) <- HashMap.toList infoMap+        , Just news <- [HashMap.lookup bId oldToNew]+        , n <- bId : news+        ]++    simplifyConstraints+      :: BindEnv+      -> HashMap SubcId (SubC a)+      -> (BindEnv, 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+       in+          (be', HashMap.fromList cs', oldToNew)++    simplifyConstraintBindings+      :: (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])])+      -> SubcId+      -> SubC a+      -> (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])])+    simplifyConstraintBindings (bindEnv, cs, newToOld) cid c =+      let env =+            [ (s, ([bId], sr))+            | bId <- elemsIBindEnv $ senv c+            , let (s, sr) = lookupBindEnv bId bindEnv+            ]++          mergedEnv = mergeDuplicatedBindings env+          undoANFEnv =+            if inlineANFBindings cfg then undoANF mergedEnv else HashMap.empty+          boolSimplEnv =+            simplifyBooleanRefts $ HashMap.union undoANFEnv mergedEnv++          modifiedBinds = HashMap.toList $ HashMap.union boolSimplEnv undoANFEnv++          modifiedBindIds = map (fst . snd) modifiedBinds++          unchangedBindIds = senv c `diffIBindEnv` fromListIBindEnv (concat modifiedBindIds)++          (newBindIds, bindEnv') = insertBinds ([], bindEnv) modifiedBinds++          newIBindEnv = insertsIBindEnv newBindIds unchangedBindIds++          newToOld' = zip newBindIds modifiedBindIds ++ newToOld+       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')++-- | If the environment contains duplicated bindings, they are+-- combined with conjunctions.+--+-- This means that @[ a : {v | P v }, a : {z | Q z }, b : {v | S v} ]@+-- is combined into @[ a : {v | P v && Q v }, b : {v | S v} ]@+--+-- If a symbol has two bindings with different sorts, none of the bindings+-- for that symbol are merged.+mergeDuplicatedBindings+  :: Semigroup m+  => [(Symbol, (m, SortedReft))]+  -> HashMap Symbol (m, SortedReft)+mergeDuplicatedBindings xs =+    HashMap.mapMaybe dropNothings $+    HashMap.fromListWith mergeSortedReft $+    map (fmap (fmap Just)) xs+  where+    dropNothings (m, msr) = (,) m <$> msr++    mergeSortedReft (bs0, msr0) (bs1, msr1) =+      let msr = do+            sr0 <- msr0+            sr1 <- msr1+            guard (sr_sort sr0 == sr_sort sr1)+            Just sr0 { sr_reft = mergeRefts (sr_reft sr0) (sr_reft sr1) }+       in+          (bs0 <> bs1, msr)++    mergeRefts r0 r1 =+      reft+        (reftBind r0)+        (pAnd+          [ reftPred r0+          , subst1 (reftPred r1) (reftBind r1, expr (reftBind r0))+          ]+        )++-- | Inlines some of the bindings introduced by ANF normalization+-- at their use sites.+--+-- Only modified bindings are returned.+--+-- Only bindings with prefix lq_anf... might be inlined.+--+-- 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)++inlineInSortedReft+  :: HashMap Symbol (m, SortedReft) -> SortedReft -> SortedReft+inlineInSortedReft env sr =+  snd $ inlineInSortedReftChanged env (error "never should evaluate", sr)++-- | 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) })++-- | Inlines bindings preffixed with @lq_anf@ in the given expression+-- if they appear in equalities.+--+-- Given a binding like @a : { v | v = e1 && e2 }@ and an expression @... e0 = a ...@,+-- this function produces the expression @... e0 = e1 ...@+-- if @v@ does not appear free in @e1@.+--+-- @... e0 = (a : s) ...@ is equally transformed to+-- @... e0 = (e1 : s) ...@+--+-- 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+  where+    inlineExpr (EVar sym)+      | anfPrefix `isPrefixOfSym` sym+      , Just (_, sr) <- HashMap.lookup sym env+      , 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+      , let r = sr_reft sr+      , Just e <- isSingletonE (reftBind r) (reftPred r)+      =+        PAtom br e0 $ subst1 e1 (sym, wrapWithCoercion br (sr_sort sr) e)+    inlineExpr e = e++    isSingletonE v (PAtom br e0 e1)+      | isEq br = isSingEq v e0 e1 `mplus` isSingEq v e1 e0+    isSingletonE v (PIff e0 e1) =+      isSingEq v e0 e1 `mplus` isSingEq v e1 e0+    isSingletonE v (PAnd cs) =+      msum $ map (isSingletonE v) cs+    isSingletonE _ _ =+      Nothing++    isSingEq v e0 e1 = do+      guard $ EVar v == dropECst e0 && not (HashSet.member v $ exprSymbolsSet e1)+      Just e1++    isEq r = r == Eq || r == Ueq++    wrapWithCoercion br to e = case exprSort_maybe 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}@+-- into @{v:bool | ~v && P false}@.+--+-- Only yields the modified bindings.+simplifyBooleanRefts+  :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)+simplifyBooleanRefts = HashMap.mapMaybe simplifyBooleanSortedReft+  where+    simplifyBooleanSortedReft (m, sr)+      | sr_sort sr == boolSort+      , let r = sr_reft sr+      , Just (e, rest) <- symbolUsedAtTopLevelAnd (reftBind r) (reftPred r)+      = let e' = pAnd $ e : map (`subst1` (reftBind r, atomToBool e)) rest+            atomToBool a = if a == EVar (reftBind r) then PTrue else PFalse+         in Just (m, sr { sr_reft = mapPredReft (const e') r })+    simplifyBooleanSortedReft _ = Nothing++    symbolUsedAtTopLevelAnd s (PAnd ps) =+      findExpr (EVar s) ps `mplus` findExpr (PNot (EVar s)) ps+    symbolUsedAtTopLevelAnd _ _ = Nothing++    findExpr e es = do+      case partition (e ==) es of+        ([], _) -> Nothing+        (e:_, rest) -> Just (e, rest)++-- | @dropLikelyIrrelevantBindings ss env@ is like @dropIrrelevantBindings@+-- but drops bindings that could potentially be necessary to validate a+-- constraint.+--+-- This function drops any bindings in the reachable set of symbols of @ss@.+-- See 'relatedSymbols'.+--+-- A constraint might be rendered unverifiable if the verification depends on+-- the environment being inconsistent. For instance, suppose the constraint+-- is @a < 0@ and we call this function like+--+-- > dropLikelyIrrelevantBindings ["a"] [a : { v | v > 0 }, b : { v | false }]+-- >   == [a : { v | v > 0 }]+--+-- The binding for @b@ is dropped since it is not otherwise related to @a@,+-- making the corresponding constraint unverifiable.+--+-- Bindings refered only from @match@ or @define@ clauses will be dropped as+-- well.+--+-- Symbols starting with a capital letter will be dropped too, as these are+-- usually global identifiers with either uninteresting or known types.+--+dropLikelyIrrelevantBindings+  :: HashSet Symbol+  -> HashMap Symbol SortedReft+  -> HashMap Symbol SortedReft+dropLikelyIrrelevantBindings ss env = HashMap.filterWithKey relevant env+  where+    relatedSyms = relatedSymbols ss env+    relevant s _sr =+      (not (capitalizedSym s) || prefixOfSym s /= s) && s `HashSet.member` relatedSyms+    capitalizedSym = Text.all isUpper . Text.take 1 . symbolText++-- | @relatedSymbols ss env@ is the set of all symbols used transitively+-- by @ss@ in @env@ or used together with it in a refinement type.+-- The output includes @ss@.+--+-- For instance, say @ss@ contains @a@, and the environment is+--+-- > a : { v | v > b }, b : int, c : { v | v >= b && b >= d}, d : int+--+-- @a@ uses @b@. Because the predicate of @c@ relates @b@ with @d@,+-- @d@ can also influence the validity of the predicate of @a@, and therefore+-- we include both @b@, @c@, and @d@ in the set of related symbols.+relatedSymbols :: HashSet Symbol -> HashMap Symbol SortedReft -> HashSet Symbol+relatedSymbols ss0 env = go HashSet.empty ss0+  where+    directlyUses = HashMap.map (exprSymbolsSet . reftPred . sr_reft) env+    usedBy = HashMap.fromListWith HashSet.union+               [ (x, HashSet.singleton s)+               | (s, xs) <- HashMap.toList directlyUses+               , x <- HashSet.toList xs+               ]++    -- @go acc ss@ contains @acc@ and @ss@ plus any symbols reachable from @ss@+    go :: HashSet Symbol -> HashSet Symbol -> HashSet Symbol+    go acc ss = case unconsHashSet ss of+      Nothing -> acc+      Just (x, xs) ->+        if x `HashSet.member` acc then go acc xs+        else+          let usersOfX = usedBy `setOf` x+              relatedToX = HashSet.unions $+                usersOfX : map (directlyUses `setOf`) (x : HashSet.toList usersOfX)+           in go (HashSet.insert x acc) (HashSet.union relatedToX xs)
src/Language/Fixpoint/Solver/Extensionality.hs view
@@ -12,7 +12,7 @@ import           Language.Fixpoint.Types.Config import           Language.Fixpoint.SortCheck import           Language.Fixpoint.Solver.Sanitize (symbolEnv)-import           Language.Fixpoint.Types hiding (mapSort)+import           Language.Fixpoint.Types hiding (mapSort, Pos) import           Language.Fixpoint.Types.Visitor ( (<$$>), mapSort )  mytracepp :: (PPrint a) => String -> a -> a
+ src/Language/Fixpoint/Solver/GradualSolve.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+-- | Solve a system of horn-clause constraints ---------------------------------+--------------------------------------------------------------------------------++module Language.Fixpoint.Solver.GradualSolve (solveGradual) where++{- COMMENTING OUT AS IT DOESNT BUILD!+import           Control.Monad (when, filterM, foldM)+import           Control.Monad.State.Strict (lift)+import           Language.Fixpoint.Misc+import qualified Language.Fixpoint.Types.Solutions as Sol+import qualified Language.Fixpoint.SortCheck       as So+import           Language.Fixpoint.Types.PrettyPrint+import qualified Language.Fixpoint.Solver.GradualSolution  as S+import qualified Language.Fixpoint.Solver.Worklist  as W+import qualified Language.Fixpoint.Solver.Eliminate as E+import           Language.Fixpoint.Solver.Monad+import           Language.Fixpoint.Utils.Progress+import           Language.Fixpoint.Graph+import           Text.PrettyPrint.HughesPJ+import           Text.Printf+import           System.Console.CmdArgs.Verbosity (whenNormal, whenLoud)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet        as S+-}++import           Control.DeepSeq+import qualified Language.Fixpoint.Types           as F+import           Language.Fixpoint.Types.Config hiding (stats)++solveGradual :: (NFData a, F.Fixpoint a) => Config -> F.SInfo a -> IO (F.Result (Integer, a))+solveGradual = undefined++++{- COMMENTING OUT AS IT DOESNT BUILD!++--------------------------------------------------------------------------------+-- | Progress Bar+--------------------------------------------------------------------------------+withProgressFI :: SolverInfo a b -> IO b -> IO b+withProgressFI = withProgress . fromIntegral . cNumScc . siDeps+--------------------------------------------------------------------------------++printStats :: F.SInfo a ->  W.Worklist a -> Stats -> IO ()+printStats fi w s = putStrLn "\n" >> ppTs [ ptable fi, ptable s, ptable w ]+  where+    ppTs          = putStrLn . showpp . mconcat++--------------------------------------------------------------------------------+solverInfo :: Config -> F.SInfo a -> SolverInfo a b+--------------------------------------------------------------------------------+solverInfo cfg fI+  | useElim cfg = E.solverInfo cfg fI+  | otherwise   = SI mempty fI cD (siKvars fI)+  where+    cD          = elimDeps fI (kvEdges fI) mempty++siKvars :: F.SInfo a -> S.HashSet F.KVar+siKvars = S.fromList . M.keys . F.ws+++--------------------------------------------------------------------------------+-- | tidyResult ensures we replace the temporary kVarArg names introduced to+--   ensure uniqueness with the original names in the given WF constraints.+--------------------------------------------------------------------------------+tidyResult :: F.Result a -> F.Result a+tidyResult r = r { F.resSolution  =  tidySolution  (F.resSolution r)+                 , F.gresSolution =  gtidySolution (F.gresSolution r)+                 }++tidySolution :: F.FixSolution -> F.FixSolution+tidySolution = fmap tidyPred++gtidySolution :: F.GFixSolution -> F.GFixSolution+gtidySolution = fmap tidyPred --  (\(e, es) -> (tidyPred e, tidyPred <$> es))++tidyPred :: F.Expr -> F.Expr+tidyPred = F.substf (F.eVar . F.tidySymbol)+++predKs :: F.Expr -> [(F.KVar, F.Subst)]+predKs (F.PAnd ps)    = concatMap predKs ps+predKs (F.PKVar k su) = [(k, su)]+predKs _              = []++++--------------------------------------------------------------------------------+minimizeResult :: Config -> M.HashMap F.KVar F.Expr+               -> SolveM (M.HashMap F.KVar F.Expr)+--------------------------------------------------------------------------------+minimizeResult cfg s+  | minimalSol cfg = mapM minimizeConjuncts s+  | otherwise      = return s++minimizeConjuncts :: F.Expr -> SolveM F.Expr+minimizeConjuncts p = F.pAnd <$> go (F.conjuncts p) []+  where+    go []     acc   = return acc+    go (p:ps) acc   = do b <- isValid (F.pAnd (acc ++ ps)) p+                         if b then go ps acc+                              else go ps (p:acc)++++showUnsat :: Bool -> Integer -> F.Pred -> F.Pred -> IO ()+showUnsat u i lP rP = {- when u $ -} do+  putStrLn $ printf   "UNSAT id %s %s" (show i) (show u)+  putStrLn $ showpp $ "LHS:" <+> pprint lP+  putStrLn $ showpp $ "RHS:" <+> pprint rP++--------------------------------------------------------------------------------+-- | Predicate corresponding to RHS of constraint in current solution+--------------------------------------------------------------------------------+rhsPred :: F.SimpC a -> F.Expr+--------------------------------------------------------------------------------+rhsPred c+  | isTarget c = F.crhs c+  | otherwise  = errorstar $ "rhsPred on non-target: " ++ show (F.sid c)++isValid :: F.Expr -> F.Expr -> SolveM Bool+isValid p q = (not . null) <$> filterValid p [(q, ())]+++-------------------------------------------------------------------------------+-- | solve with edits to allow Gradual types ----------------------------------+-------------------------------------------------------------------------------++solveGradual :: (NFData a, F.Fixpoint a) => Config -> F.SInfo a -> IO (F.Result (Integer, a))+-- solveGradual = undefined++solveGradual cfg fi = do+    (res, stat) <- withProgressFI sI $ runSolverM cfg sI n act+    when (solverStats cfg) $ printStats fi wkl stat+    return res+  where+    act  = solveGradual_ cfg fi s0 ks  wkl+    sI   = solverInfo cfg fi+    wkl  = W.init sI+    n    = fromIntegral $ W.wRanks wkl+    s0   = siSol  sI+    ks   = siVars sI++--------------------------------------------------------------------------------+solveGradual_ :: (NFData a, F.Fixpoint a)+       => Config+       -> F.SInfo a+       -> Sol.GSolution+       -> S.HashSet F.KVar+       -> W.Worklist a+       -> SolveM (F.Result (Integer, a), Stats)+--------------------------------------------------------------------------------+solveGradual_ cfg fi s0 ks wkl = do+  let s1  = mappend s0 $ {- SCC "sol-init" #-} S.init cfg fi ks+  s2      <- {- SCC "sol-local"  #-} filterLocal s1+  s       <- {- SCC "sol-refine" #-} refine s2 wkl+  res     <- {- SCC "sol-result" #-} result cfg wkl s+  st      <- stats+  let res' = {- SCC "sol-tidy"   #-} tidyResult res+  return $!! (res', st)++filterLocal :: Sol.GSolution -> SolveM Sol.GSolution+filterLocal sol = do+  gs' <- mapM (initGBind sol) gs+  return $ Sol.updateGMap sol $ M.fromList gs'+  where+    gs = M.toList $ Sol.gMap sol++initGBind :: Sol.GSolution -> (F.KVar, (((F.Symbol, F.Sort), F.Expr), Sol.GBind)) -> SolveM (F.KVar, (((F.Symbol, F.Sort), F.Expr), Sol.GBind))+initGBind sol (k, (e, gb)) = do+   elems0  <- filterM (isLocal e) (Sol.gbEquals gb)+   elems   <- sortEquals elems0+   lattice <- makeLattice [] (map (:[]) elems) elems+   return $ ((k,) . (e,) . Sol.equalsGb) lattice+  where+    makeLattice acc new elems+      | null new+      = return acc+      | otherwise+      = do let cands = [e:es |e<-elems, es<-new]+           localCans <- filterM (isLocal e) cands+           newElems  <- filterM (notTrivial (new ++ acc)) localCans+           makeLattice (acc ++ new) newElems elems++    notTrivial [] _     = return True+    notTrivial (x:xs) p = do v <- isValid (mkPred x) (mkPred p)+                             if v then return False+                                  else notTrivial xs p++    mkPred eq = So.elaborate "initBGind.mkPred" (Sol.sEnv sol) (F.pAnd (Sol.eqPred <$> eq))+    isLocal (v, e) eqs = do+      let pp = So.elaborate "filterLocal" (Sol.sEnv sol) $ F.PExist [v] $ F.pAnd (e:(Sol.eqPred <$> eqs))+      isValid mempty pp++    root      = Sol.trueEqual+    sortEquals xs = (bfs [0]) <$> makeEdges vs [] vs+      where+       vs        = zip [0..] (root:(head <$> xs))++       bfs []     _  = []+       bfs (i:is) es = (snd $ (vs!!i)) : bfs (is++map snd (filter (\(j,k) ->  (j==i && notElem k is)) es)) es++       makeEdges _   acc []    = return acc+       makeEdges vs acc (x:xs) = do ves  <- concat <$> mapM (makeEdgesOne x) vs+                                    if any (\(i,j) -> elem (j,i) acc) ves+                                      then makeEdges (filter ((/= fst x) . fst) vs) (filter (\(i,j) -> ((i /= fst x) && (j /= fst x))) acc) xs+                                      else makeEdges vs (mergeEdges (ves ++ acc)) xs++    makeEdgesOne (i,_) (j,_) | i == j = return []+    makeEdgesOne (i,x) (j,y) = do+      ij <- isValid (mkPred [x]) (mkPred [y])+      return (if ij then [(j,i)] else [])++    mergeEdges es = filter (\(i,j) -> (not (any (\k -> ((i,k) `elem` es && (k,j) `elem` es)) (fst <$> es)))) es+++--------------------------------------------------------------------------------+refine :: Sol.GSolution -> W.Worklist a -> SolveM Sol.GSolution+--------------------------------------------------------------------------------+refine s w+  | Just (c, w', newScc, rnk) <- W.pop w = do+     i       <- tickIter newScc+     (b, s') <- refineC i s c+     lift $ writeLoud $ refineMsg i c b rnk+     let w'' = if b then W.push c w' else w'+     refine s' w''+  | otherwise = return s+  where+    -- DEBUG+    refineMsg i c b rnk = printf "\niter=%d id=%d change=%s rank=%d\n"+                            i (F.subcId c) (show b) rnk++---------------------------------------------------------------------------+-- | Single Step Refinement -----------------------------------------------+---------------------------------------------------------------------------+refineC :: Int -> Sol.GSolution -> F.SimpC a -> SolveM (Bool, Sol.GSolution)+---------------------------------------------------------------------------+refineC _i s c+  | null rhs  = return (False, s)+  | otherwise = do be      <- getBinds+                   let lhss = snd <$> S.lhsPred be s c+                   kqs     <- filterValidGradual lhss rhs+                   return   $ S.update s ks kqs+  where+    _ci       = F.subcId c+    (ks, rhs) = rhsCands s c+    -- msg       = printf "refineC: iter = %d, sid = %s, soln = \n%s\n"+    --               _i (show (F.sid c)) (showpp s)+    _msg ks xs ys = printf "refineC: iter = %d, sid = %s, s = %s, rhs = %d, rhs' = %d \n"+                     _i (show _ci) (showpp ks) (length xs) (length ys)+++rhsCands :: Sol.GSolution -> F.SimpC a -> ([F.KVar], Sol.Cand (F.KVar, Sol.EQual))+rhsCands s c    = (fst <$> ks, kqs)+  where+    kqs         = [ (p, (k, q)) | (k, su) <- ks, (p, q)  <- cnd k su ]+    ks          = predKs . F.crhs $ c+    cnd k su    = Sol.qbPreds msg s su (Sol.lookupQBind s k)+    msg         = "rhsCands: " ++ show (F.sid c)++--------------------------------------------------------------------------------+-- | Gradual Convert Solution into Result ----------------------------------------------+--------------------------------------------------------------------------------+result :: (F.Fixpoint a) => Config -> W.Worklist a -> Sol.GSolution+       -> SolveM (F.Result (Integer, a))+--------------------------------------------------------------------------------+result cfg wkl s = do+  lift $ writeLoud "Computing Result"+  stat    <- result_ wkl s+  lift $ whenNormal $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat)+  F.Result (ci <$> stat) <$> solResult cfg s <*> solResultGradual wkl cfg s+  where+    ci c = (F.subcId c, F.sinfo c)++result_ :: Fixpoint a =>  W.Worklist a -> Sol.GSolution -> SolveM (F.FixResult (F.SimpC a))+result_  w s = res <$> filterM (isUnsat s) cs+  where+    cs       = W.unsatCandidates w+    res []   = F.Safe+    res cs'  = F.Unsafe cs'++solResult :: Config -> Sol.GSolution -> SolveM (M.HashMap F.KVar F.Expr)+solResult cfg+  = minimizeResult cfg . Sol.result+++solResultGradual :: W.Worklist a -> Config -> Sol.GSolution -> SolveM F.GFixSolution+solResultGradual w _cfg sol+  = F.toGFixSol . Sol.resultGradual <$> updateGradualSolution (W.unsatCandidates w) sol++--------------------------------------------------------------------------------+updateGradualSolution :: [F.SimpC a] -> Sol.GSolution -> SolveM (Sol.GSolution)+--------------------------------------------------------------------------------+updateGradualSolution cs sol = foldM f (Sol.emptyGMap sol) cs+  where+   f s c = do+    be <- getBinds+    let lpi = S.lhsPred be sol c+    let rp  = rhsPred c+    gbs    <- firstValid rp lpi+    return $ Sol.updateGMapWithKey gbs s+++firstValid :: Monoid a =>  F.Expr -> [(a, F.Expr)] -> SolveM a+firstValid _   [] = return mempty+firstValid rhs ((y,lhs):xs) = do+  v <- isValid lhs rhs+  if v then return y else firstValid rhs xs+++--------------------------------------------------------------------------------+isUnsat :: Fixpoint a => Sol.GSolution -> F.SimpC a -> SolveM Bool+--------------------------------------------------------------------------------+isUnsat s c = do+  -- lift   $ printf "isUnsat %s" (show (F.subcId c))+  _     <- tickIter True -- newScc+  be    <- getBinds+  let lpi = S.lhsPred be s c+  let rp = rhsPred        c+  res   <- (not . or) <$> mapM (`isValid` rp) (snd <$> lpi)+  lift   $ whenLoud $ showUnsat res (F.subcId c) (F.pOr (snd <$> lpi)) rp+  return res+++-}
src/Language/Fixpoint/Solver/Instantiate.hs view
@@ -33,6 +33,7 @@ import           Language.Fixpoint.Solver.Sanitize        (symbolEnv) import qualified Language.Fixpoint.Solver.PLE as PLE      (instantiate) import           Control.Monad.State+import           Data.Bifunctor (second) import qualified Data.Text            as T import qualified Data.HashMap.Strict  as M import qualified Data.HashSet         as S@@ -48,27 +49,35 @@ -------------------------------------------------------------------------------- -- | Strengthen Constraint Environments via PLE  ---------------------------------------------------------------------------------instantiate :: (Loc a) => Config -> SInfo a -> IO (SInfo a)-instantiate cfg fi-  | rewriteAxioms cfg && not (oldPLE cfg)-  = PLE.instantiate cfg fi+instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instantiate cfg fi subcIds+  | not (oldPLE cfg)+  = PLE.instantiate cfg fi subcIds -  | rewriteAxioms cfg && noIncrPle cfg-  = instantiate' cfg fi+  | noIncrPle cfg+  = instantiate' cfg fi subcIds -  | rewriteAxioms cfg -- && incrPle cfg -  = incrInstantiate' cfg fi+  | otherwise+  = incrInstantiate' cfg fi subcIds -  | otherwise         -  = return fi  ------------------------------------------------------------------------------- --- | New "Incremental" PLE+-- | 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 +           forall 0 <= j < i, j in c and j in c'++ -}+ ------------------------------------------------------------------------------- -incrInstantiate' :: (Loc a) => Config -> SInfo a -> IO (SInfo a)+incrInstantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a) ------------------------------------------------------------------------------- -incrInstantiate' cfg fi = do -    let cs = [ (i, c) | (i, c) <- M.toList (cm fi), isPleCstr aEnv i c ] +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) $                 withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs)  -- 2. TRAVERSE Trie to compute InstRes@@ -268,9 +277,9 @@     cands     = (S.fromList (concatMap topApps es0)) `S.difference` (icSolved ctx)     ctxEqs    = toSMT ieCfg ieSMT [] <$> concat                    [ initEqs -                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvars r) ] +                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]                   ]-    (bs, es0) = (unElab <$> binds, unElab <$> es)+    (bs, es0) = (second unElabSortedReft <$> binds, unElab <$> es)     es        = eRhs : (expr <$> binds)      eRhs      = maybe PTrue crhs subMb     binds     = [ lookupBindEnv i ieBEnv | i <- delta ] @@ -282,12 +291,13 @@ -------------------------------------------------------------------------------- -- | "Old" GLOBAL PLE  ---------------------------------------------------------------------------------instantiate' :: (Loc a) => Config -> SInfo a -> IO (SInfo a)-instantiate' cfg fi = sInfo cfg env fi <$> withCtx cfg file env act+instantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instantiate' cfg fi subcIds = sInfo cfg env fi <$> withCtx cfg file env act   where     act ctx         = forM cstrs $ \(i, c) ->                         ((i,srcSpan c),) . mytracepp  ("INSTANTIATE i = " ++ show i) <$> instSimpC cfg ctx (bs fi) aenv i c-    cstrs           = [ (i, c) | (i, c) <- M.toList (cm fi) , isPleCstr aenv i c] +    cstrs           = [ (i, c) | (i, c) <- M.toList (cm fi) , isPleCstr aenv i c+                               ,  maybe True (i `L.elem`) subcIds ]     file            = srcFile cfg ++ ".evals"     env             = symbolEnv cfg fi     aenv            = {- mytracepp  "AXIOM-ENV" -} (ae fi)@@ -313,7 +323,7 @@ isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv)   cstrExprs :: BindEnv -> SimpC a -> ([(Symbol, SortedReft)], [Expr])-cstrExprs bds sub = (unElab <$> binds, unElab <$> es)+cstrExprs bds sub = (second unElabSortedReft <$> binds, unElab <$> es)   where     es            = (crhs sub) : (expr <$> binds)     binds         = envCs bds (senv sub)@@ -333,7 +343,7 @@   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.kvars r) ] +              ++ [ toSMT cfg ctx [] (expr xr)   | xr@(_, r) <- facts, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]   eqss        <- _evalLoop cfg ctx γ s0 ctxEqs cands    return       $ eqs ++ eqss @@ -606,14 +616,14 @@             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 ) ) ~>)                       else return e@@ -693,7 +703,7 @@ askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool askSMT cfg ctx bs e   | isTautoPred  e     = return True-  | null (Vis.kvars e) = SMT.checkValidWithContext ctx [] PTrue e'+  | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e'   | otherwise          = return False   where      e'                 = toSMT cfg ctx bs e
src/Language/Fixpoint/Solver/Monad.hs view
@@ -19,12 +19,14 @@        , filterValidGradual        , checkSat        , smtEnablembqi+       , sendConcreteBindingsToSMT           -- * Debug        , Stats        , tickIter        , stats        , numIter+       , SolverState(..)        )        where @@ -35,6 +37,7 @@ -- import qualified Language.Fixpoint.Misc    as Misc -- import           Language.Fixpoint.SortCheck import qualified Language.Fixpoint.Types.Solutions as F+import qualified Language.Fixpoint.Types.Visitor as F -- import qualified Language.Fixpoint.Types.Errors  as E import           Language.Fixpoint.Smt.Serialize () import           Language.Fixpoint.Types.PrettyPrint ()@@ -75,7 +78,7 @@ runSolverM cfg sI act =   bracket acquire release $ \ctx -> do     res <- runStateT act' (s0 ctx)-    smtWrite ctx "(exit)"+    smtExit ctx     return (fst res)   where     s0 ctx   = SS ctx be (stats0 fi)@@ -124,6 +127,35 @@ -------------------------------------------------------------------------------- -- | SMT Interface ------------------------------------------------------------- --------------------------------------------------------------------------------++-- | Takes the environment of bindings already known to the SMT,+-- and the environment of all bindings that need to be known.+--+-- Yields the ids of bindings known to the SMT+sendConcreteBindingsToSMT+  :: F.IBindEnv -> (F.IBindEnv -> SolveM a) -> SolveM 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+        , F.isConc p+        , not (isShortExpr p)+        , not (F.memberIBindEnv i known)+        ]+  st <- get+  (a, st') <- withContext $ \me -> do+    smtBracket me "" $ do+      forM_ concretePreds $ \(i, e) ->+        smtDefineFunc me (F.bindSymbol (fromIntegral i)) [] F.boolSort e+      flip runStateT st $ act $ F.unionIBindEnv known $ F.fromListIBindEnv $ map fst concretePreds+  put st'+  return a+  where+    isShortExpr F.PTrue = True+    isShortExpr F.PTop = True+    isShortExpr _ = False+ -- | `filterRequired [(x1, p1),...,(xn, pn)] q` returns a minimal list [xi] s.t. --   /\ [pi] => q --------------------------------------------------------------------------------@@ -153,6 +185,7 @@ -------------------------------------------------------------------------------- -- | `filterValid p [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` --------------------------------------------------------------------------------+{-# SCC filterValid #-} filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM [a] -------------------------------------------------------------------------------- filterValid sp p qs = do@@ -165,14 +198,17 @@   incVald (length qs')   return qs' +{-# SCC filterValid_ #-} filterValid_ :: F.SrcSpan -> F.Expr -> F.Cand a -> Context -> IO [a] filterValid_ sp p qs me = catMaybes <$> do-  smtAssert me p-  forM qs $ \(q, x) ->-    smtBracketAt sp me "filterValidRHS" $ do-      smtAssert me (F.PNot q)-      valid <- smtCheckUnsat me-      return $ if valid then Just x else Nothing+  smtAssertAsync me p+  forM_ qs $ \(q, _x) ->+    smtBracketAsyncAt sp me "filterValidRHS" $ do+      smtAssertAsync me (F.PNot q)+      smtCheckUnsatAsync me+  forM qs $ \(_, x) -> do+    valid <- readCheckUnsat me+    return $ if valid then Just x else Nothing   --------------------------------------------------------------------------------@@ -212,8 +248,7 @@  smtEnablembqi :: SolveM () smtEnablembqi-  = withContext $ \me ->-      smtWrite me "(set-option :smt.mbqi true)"+  = withContext smtSetMbqi  -------------------------------------------------------------------------------- checkSat :: F.Expr -> SolveM  Bool
src/Language/Fixpoint/Solver/PLE.hs view
@@ -23,65 +23,127 @@  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') -  | False -- True -  , e /= e' -  = trace ("\n" ++ showpp e ++ " ~> " ++ showpp e') (e,e') -  | otherwise +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  ---------------------------------------------------------------------------------instantiate :: (Loc a) => Config -> SInfo a -> IO (SInfo a)-instantiate cfg fi' = do -    let cs = [ (i, c) | (i, c) <- M.toList (cm fi), isPleCstr aEnv i c ] -    let t  = mkCTrie cs                                               -- 1. BUILD the Trie-    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+{-# 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 -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a -instEnv cfg fi cs ctx = InstEnv cfg ctx bEnv aEnv cs γ s0-  where +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+    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 +-- | 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@@ -94,35 +156,61 @@   where      diff0        = []     res0         = M.empty -    ctx0         = initCtx $ ((mkEq <$> es0) ++ (mkEq' <$> es0'))+    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 +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 -> Maybe BindId -> InstRes -> CBranch -> IO InstRes-loopB env ctx delta iMb res b = case b of +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 +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'+    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)@@ -134,45 +222,53 @@ 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 +evalCandsLoop cfg ictx0 ctx γ env = go ictx0 0   where     withRewrites exprs =       let-        rws = [rewrite e rw | rw <- knSims γ-                            ,  e <- S.toList (snd `S.map` exprs)]+        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 =  do let cands = icCands ictx-                  let env' = env {  evAccum    = icEquals   ictx <> evAccum env }-                  evalResults   <- SMT.smtBracket ctx "PLE.evaluate" $ do-                               SMT.smtAssert ctx (pAnd (S.toList $ icAssms ictx)) -                               mapM (evalOne γ env' ictx) (S.toList cands)+    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  = icAssms  ictx <> S.filter (not . isTautoPred) eqsSMT }-                                 let newcands = mconcat (makeCandidates γ ictx' <$> S.toList (cands <> (snd `S.map` us)))-                                 go (ictx' { icCands = S.fromList newcands})+                                 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 -> Rewrite -> [(Expr,Expr)] -rewrite e rw = Mb.catMaybes $ map (`rewriteTop` rw) (notGuardedApps e)+rewrite :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)] +rewrite e rwEnv = concat $ map (`rewriteTop` rwEnv) (notGuardedApps e) -rewriteTop :: Expr -> Rewrite -> Maybe (Expr,Expr) -rewriteTop e rw-  | (EVar f, es) <- splitEApp e-  , f == smDC rw+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)-  = 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 @@ -195,7 +291,7 @@   , ieSMT   :: !SMT.Context   , ieBEnv  :: !BindEnv   , ieAenv  :: !AxiomEnv -  , ieCstrs :: ![(SubcId, SimpC a)]+  , ieCstrs :: !(CMap (SimpC a))   , ieKnowl :: !Knowledge   , ieEvEnv :: !EvalEnv   } @@ -211,6 +307,8 @@   , 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   }   ---------------------------------------------------------------------------------------------- @@ -229,14 +327,16 @@ type CBranch = T.Branch SubcId type Diff    = [BindId]    -- ^ in "reverse" order -initCtx :: [(Expr,Expr)] -> ICtx-initCtx es = ICtx -  { icAssms    = mempty -  , icCands    = mempty -  , icEquals   = S.fromList es-  , icSolved   = mempty-  , icSimpl    = mempty -  , icSubcId   = Nothing+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]@@ -249,7 +349,7 @@   updRes :: InstRes -> Maybe BindId -> Expr -> InstRes-updRes res (Just i) e = M.insert i e res +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   ---------------------------------------------------------------------------------------------- @@ -257,31 +357,32 @@ --   to the context.  ----------------------------------------------------------------------------------------------  -updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx +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 = fst <$> L.find (\(_, b) -> (head delta) `memberIBindEnv` (_cenv b)) ieCstrs+                    , icSubcId = cidMb+                    , icANFs   = anfs <> icANFs ctx                     }   where         -    initEqs   = S.fromList $ concat [rewrite e rw | e  <- (cands ++ (snd <$> S.toList (icEquals ctx)))-                                                  , rw <- knSims ieKnowl]+    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 +    ctxEqs    = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub (concat                   [ equalitiesPred initEqs                    , equalitiesPred sims                    , equalitiesPred (icEquals ctx)-                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvars r) ] +                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]                   ])-    bs        = unElab <$> binds+    bs        = second unElabSortedReft <$> binds     (rhs:es)  = unElab <$> (eRhs : (expr <$> binds))     eRhs      = maybe PTrue crhs subMb-    binds     = [ lookupBindEnv i ieBEnv | i <- delta ] -    subMb     = getCstr (M.fromList ieCstrs) <$> cidMb+    binds     = [ lookupBindEnv i ieBEnv | i <- delta ]+    subMb     = getCstr ieCstrs <$> cidMb   findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]@@ -300,13 +401,13 @@ 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)+    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 +    isIte EIte {} = True +    isIte _       = False    isGoodApp :: Knowledge -> Expr -> Bool @@ -332,8 +433,22 @@ 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 -------------------------------------------------------------------------------- @@ -344,13 +459,27 @@     cid <- icSubcId ctx     M.lookup cid $ knAutoRWs γ -evalOne :: Knowledge -> EvalEnv -> ICtx -> Expr -> IO EvAccum-evalOne γ env ctx e | null $ getAutoRws γ ctx = do-    (e',st) <- runStateT (fastEval γ ctx e) env -    return $ if e' == e then evAccum st else S.insert (e, e') (evAccum st)-evalOne γ env ctx e =-  evAccum <$> execStateT (eval γ ctx [(e, PLE)]) env+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 @@ -379,165 +508,330 @@   -subsFromAssm :: Expr -> [(Symbol, Expr)]-subsFromAssm (PAnd es)                                   = concatMap subsFromAssm es-subsFromAssm (EEq lhs rhs) | (EVar v) <- unElab lhs-                           , anfPrefix `isPrefixOfSym` v = [(v, unElab rhs)]-subsFromAssm _                                           = []+-- 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) -fastEval :: Knowledge -> ICtx -> Expr -> EvalST Expr-fastEval _ ctx e++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+  = return (v, noExpand)   -fastEval γ ctx e =-  do acc       <- S.toList . evAccum <$> get+eval γ ctx et e =+  do acc <- gets (S.toList . evAccum)      case L.lookup e acc of-        Just e' -> fastEval γ ctx e'+        -- If rewriting, don't lookup, as evAccum may contain loops+        Just e' | null (getAutoRws γ ctx) -> eval γ ctx et e'         _ -> do-          e'  <- simplify γ ctx <$> go e-          if e /= e'-            then do modify (\st -> st { evAccum = S.insert (traceE (e, e')) (evAccum st)-                                      })-                    fastEval γ (addConst (e,e') ctx) e'-            else return e+          (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)   = ELam (x, s) <$> fastEval γ' ctx e where γ' = γ { knLams = (x, s) : knLams γ }-    go e@(EIte b e1 e2) = fastEvalIte γ ctx e b e1 e2-    go (ECoerc s t e)   = ECoerc s t  <$> go e-    go e@(EApp _ _)     = case splitEApp e of -                           (f, es) -> do (f':es') <- mapM (fastEval γ ctx) (f:es) -                                         evalApp γ ctx (eApps f' es) (f',es')-    go e@(PAtom r e1 e2) = fromMaybeM (PAtom r <$> go e1 <*> go e2) (evalBool γ e)-    go (ENeg e)         = do e'  <- fastEval γ ctx e-                             return $ ENeg e'-    go (EBin o e1 e2)   = do e1' <- fastEval γ ctx e1 -                             e2' <- fastEval γ ctx e2 -                             return $ EBin o e1' e2'-    go (ETApp e t)      = flip ETApp t <$> go e-    go (ETAbs e s)      = flip ETAbs s <$> go e-    go e@(PNot e')      = fromMaybeM (PNot <$> go e')           (evalBool γ e)-    go e@(PImp e1 e2)   = fromMaybeM (PImp <$> go e1 <*> go e2) (evalBool γ e)-    go e@(PIff e1 e2)   = fromMaybeM (PIff <$> go e1 <*> go e2) (evalBool γ e)-    go e@(PAnd es)      = fromMaybeM (PAnd <$> (go  <$$> es))   (evalBool γ e)-    go e@(POr es)       = fromMaybeM (POr  <$> (go <$$> es))    (evalBool γ e)-    go e                = return e+    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') -eval :: Knowledge -> ICtx -> [(Expr, TermOrigin)] -> EvalST ()-eval _ ctx path-  | pathExprs <- map fst path+    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)})         -eval γ ctx path =+evalREST γ ctx rp =   do-    rws <- getRWs -    e'  <- simplify γ ctx <$> evalStep γ ctx e-    let evalIsNewExpr = L.notElem e' pathExprs-    let exprsToAdd    = (if evalIsNewExpr then [e'] else []) ++ map fst rws-    let evAccum'      = S.fromList $ map (e,) $ exprsToAdd-    modify (\st -> st { evAccum = S.union evAccum' (evAccum st)})-    when evalIsNewExpr $ eval γ (addConst (e, e')) (path ++ [(e', PLE)])-    mapM_ (\rw -> (eval γ ctx) (path ++ [rw])) rws+    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-    pathExprs = map fst path-    e         = last pathExprs-    autorws   = getAutoRws γ ctx+    shouldExploreTerm et e =+      case rwTerminationOpts rwArgs of+        RWTerminationCheckDisabled -> return $ not $ visited (convert e) et+        RWTerminationCheckEnabled  -> shouldExplore (convert e) (c rp) et -    getRWs :: EvalST [(Expr, TermOrigin)]-    getRWs =+    allowed (rwE, _) | rwE `elem` pathExprs = return False+    allowed (_, c)   | otherwise = termCheck c+    termCheck c = passesTerminationCheck (oc rp) rwArgs c++    notVisitedFirst et rws =       let-        ints      = concatMap subsFromAssm (S.toList $ icAssms ctx)-        su        = Su (M.fromList ints)-        e'        = subst' e-        subst' ee =-          let ee' = subst su ee-          in if ee == ee' then ee else subst' ee'-        rwArgs = RWArgs (isValid γ) (knRWTerminationOpts γ)-        getRWs' s = -          Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRewrite rwArgs path s) autorws-      in concat <$> mapM getRWs' (subExprs e')-          -    addConst (e,e') = if isConstant (knDCs γ) e'-                      then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx +        (v, nv) = L.partition (\(e, _) -> visited (convert e) et) rws+      in+        nv ++ v -evalStep :: Knowledge -> ICtx -> Expr -> EvalST Expr-evalStep γ ctx (ELam (x,s) e)   = ELam (x, s) <$> evalStep γ' ctx e where γ' = γ { knLams = (x, s) : knLams γ }-evalStep γ ctx e@(EIte b e1 e2) = evalIte γ ctx e b e1 e2-evalStep γ ctx (ECoerc s t e)   = ECoerc s t <$> evalStep γ ctx e-evalStep γ ctx e@(EApp _ _)     = case splitEApp e of -  (f, es) ->-    do-      f' <- evalStep γ ctx f-      if f' /= f-        then return (eApps f' es)-        else-          do-            es' <- mapM (evalStep γ ctx) es-            if es /= es'-              then return (eApps f' es')-              else evalApp γ ctx (eApps f' es') (f',es')-evalStep γ ctx e@(PAtom r e1 e2) =-  fromMaybeM (PAtom r <$> evalStep γ ctx e1 <*> evalStep γ ctx e2) (evalBool γ e)-evalStep γ ctx (ENeg e) = ENeg <$> evalStep γ ctx e-evalStep γ ctx (EBin o e1 e2)   = do-  e1' <- evalStep γ ctx e1-  if e1' /= e1-    then return (EBin o e1' e2)-    else EBin o e1 <$> evalStep γ ctx e2-evalStep γ ctx (ETApp e t)      = flip ETApp t <$> evalStep γ ctx e-evalStep γ ctx (ETAbs e s)      = flip ETAbs s <$> evalStep γ ctx e-evalStep γ ctx e@(PNot e')      = fromMaybeM (PNot <$> evalStep γ ctx e') (evalBool γ e)-evalStep γ ctx e@(PImp e1 e2)   = fromMaybeM (PImp <$> evalStep γ ctx e1 <*> evalStep γ ctx e2) (evalBool γ e)-evalStep γ ctx e@(PIff e1 e2)   = fromMaybeM (PIff <$> evalStep γ ctx e1 <*> evalStep γ ctx e2) (evalBool γ e)-evalStep γ ctx e@(PAnd es)      = fromMaybeM (PAnd <$> (evalStep γ ctx <$$> es)) (evalBool γ e)-evalStep γ ctx e@(POr es)       = fromMaybeM (POr  <$> (evalStep γ ctx <$$> es)) (evalBool γ e)-evalStep _ _   e                = return e+    rpEval e' =+      let+        c' =+          if any isRW (path rp)+            then refine (oc rp) (c rp) e e'+            else c rp -fromMaybeM :: (Monad m) => m a -> m (Maybe a) -> m a -fromMaybeM a ma = do -  mx <- ma -  case mx of -    Just x  -> return x -    Nothing -> a  +      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 :: Knowledge -> ICtx -> Expr -> (Expr, [Expr]) -> EvalST Expr-evalApp γ ctx _ (EVar f, es)-  | Just eq <- L.find ((== f) . eqName) (knAms γ)+-- | @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 <- seSort <$> gets evEnv-       let (es1,es2) = splitAt (length (eqArgs eq)) es-       shortcut (substEq env eq es1) es2+  = 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   <- fastEval γ ctx i-      b'  <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp b) <$> isValid γ b)-      nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (PNot b)) <$> isValid γ (PNot b))+      (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+        else return $ (eApps (EIte b e1 e2) es2, expand)       return r-    shortcut e' es2 = return $ eApps e' es2+    shortcut e' es2 = return $ (eApps e' es2, noExpand) -evalApp γ _ _ (EVar f, e:es) +evalApp γ _ (EVar f) (e:es) _   | (EVar dc, as) <- splitEApp e-  , Just rw <- L.find (\rw -> smName rw == f && smDC rw == dc) (knSims γ)+  , 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 +  = return (eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es, noExpand) -evalApp _ _ e _-  = return e -  +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@@ -587,42 +881,30 @@     if bf then return $ Just PFalse            else return Nothing                -fastEvalIte :: Knowledge -> ICtx -> Expr -> Expr -> Expr -> Expr -> EvalST Expr-fastEvalIte γ ctx _ b0 e1 e2 = do -  b <- fastEval γ ctx b0 +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 -    else if nb' then return $ e2 -    else return $ EIte b e1 e2  +    then return (e1, noExpand)+    else if nb' then return $ (e2, noExpand)+    else return $ (EIte b e1 e2, fe) -evalIte :: Knowledge -> ICtx -> Expr -> Expr -> Expr -> Expr -> EvalST Expr-evalIte γ ctx _ b0 e1 e2 = do -  b   <- evalStep γ ctx b0-  if b /= b0 then return (EIte b e1 e2) else-    do-      b'  <- liftIO $ isValid γ b-      nb' <- liftIO $ isValid γ (PNot b)-      return $-        if b'-        then e1-        else if nb' then e2 -        else EIte b e1 e2-         -------------------------------------------------------------------------------- -- | Knowledge (SMT Interaction) -------------------------------------------------------------------------------- data Knowledge = KN -  { knSims              :: ![Rewrite]           -- ^ Rewrite rules came from match and data type definitions -  , knAms               :: ![Equation]          -- ^ All function definitions+  { 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)+  , 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   }@@ -636,26 +918,48 @@  knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge knowledge cfg ctx si = KN -  { knSims                     = sims -  , knAms                      = aenvEqs aenv+  { 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)-  , knDCs                      = S.fromList (smDC <$> sims) +                                 ++ 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 (maxRWOrderingConstraints cfg)+      then RWTerminationCheckEnabled       else RWTerminationCheckDisabled   }    where -    sims = aenvSimpl aenv ++ concatMap reWriteDDecl (ddecls si) -    aenv = ae si +    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))@@ -668,20 +972,11 @@       | otherwise        = Nothing  -reWriteDDecl :: DataDecl -> [Rewrite]-reWriteDDecl ddecl = concatMap go (ddCtors ddecl) -  where -    go (DCtor f xs) = zipWith (\r i -> SMeasure r f' ys (EVar (ys!!i)) ) rs [0..]-       where -        f'  = symbol f -        rs  = (val . dfName) <$> xs  -        mkArg ws = zipWith (\_ i -> intSymbol (symbol ("darg"::String)) i) ws [0..]-        ys  = mkArg xs - askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool askSMT cfg ctx bs e+--   | isContraPred e     = return False    | isTautoPred  e     = return True-  | null (Vis.kvars e) = SMT.checkValidWithContext ctx [] PTrue e'+  | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e'   | otherwise          = return False   where      e'                 = toSMT "askSMT" cfg ctx bs e @@ -721,19 +1016,21 @@     isConstant :: S.HashSet LDataCon -> Expr -> Bool -isConstant dcs e = S.null (S.difference (S.fromList $ syms e) dcs) +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.mapExpr tx) e +  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@@ -749,10 +1046,49 @@         , (EVar dc', es) <- splitEApp a         , dc == dc'          = es!!i-      tx e = e  +      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 ------------------- -------------------------------------------------------------------------------@@ -810,3 +1146,23 @@     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 +  fc <- gets evFuel+  case (M.lookup f (fcMap fc), fcMax fc) of+    (Just fk, Just n) -> pure (fk <= n)+    _                 -> pure True
+ src/Language/Fixpoint/Solver/Prettify.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | Functions to make environments easier to read+module Language.Fixpoint.Solver.Prettify (savePrettifiedQuery) where++import           Data.Bifunctor (first)+import           Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import           Data.List (intersperse, sortOn)+import           Data.Maybe (fromMaybe)+import           Data.Text (Text)+import qualified Data.Text as Text+import           Language.Fixpoint.Misc (ensurePath)+import           Language.Fixpoint.Solver.EnvironmentReduction+  ( dropLikelyIrrelevantBindings+  , inlineInSortedReft+  , mergeDuplicatedBindings+  , simplifyBooleanRefts+  , undoANF+  )+import           Language.Fixpoint.Types.Config (Config, queryFile)+import           Language.Fixpoint.Types.Constraints+import           Language.Fixpoint.Types.Environments+  (BindEnv, elemsIBindEnv, lookupBindEnv)+import           Language.Fixpoint.Types.Names+  ( Symbol+  , dropPrefixOfSym+  , prefixOfSym+  , suffixOfSym+  , suffixSymbol+  , symbol+  , symbolText+  )+import           Language.Fixpoint.Types.PrettyPrint+import           Language.Fixpoint.Types.Refinements+  ( Expr(..)+  , Reft+  , SortedReft(..)+  , conjuncts+  , reft+  , reftBind+  , reftPred+  , sortedReftSymbols+  , substf+  , substSortInExpr+  )+import           Language.Fixpoint.Types.Sorts (Sort(..), substSort)+import           Language.Fixpoint.Types.Substitutions (exprSymbolsSet)+import qualified Language.Fixpoint.Utils.Files as Files+import           System.FilePath (addExtension)+import           Text.PrettyPrint.HughesPJ.Compat+  (Doc, braces, hang, nest, render, sep, text, vcat, (<+>), ($+$))+++savePrettifiedQuery :: Fixpoint a => Config -> FInfo a -> IO ()+savePrettifiedQuery cfg fi = do+  let fq   = queryFile Files.Fq cfg `addExtension` "prettified"+  putStrLn $ "Saving prettified Query: "   ++ fq ++ "\n"+  ensurePath fq+  writeFile fq $ render (prettyConstraints fi)++prettyConstraints :: Fixpoint a => FInfo a -> Doc+prettyConstraints fi =+  vcat $+  map (prettyConstraint (bs fi)) $+  map snd $+  sortOn fst $+  HashMap.toList (cm fi)++prettyConstraint+  :: Fixpoint a+  => BindEnv+  -> SubC a+  -> Doc+prettyConstraint bindEnv c =+  let env = [ (s, ([bId], sr))+            | bId <- elemsIBindEnv $ senv c+            , let (s, sr) = lookupBindEnv bId bindEnv+            ]+      mergedEnv = mergeDuplicatedBindings env+      undoANFEnv = HashMap.union (undoANF mergedEnv) mergedEnv+      boolSimplEnv = HashMap.union (simplifyBooleanRefts undoANFEnv) undoANFEnv++      simplifiedLhs = inlineInSortedReft boolSimplEnv (slhs c)+      simplifiedRhs = inlineInSortedReft boolSimplEnv (srhs c)++      prunedEnv =+        dropLikelyIrrelevantBindings (constraintSymbols simplifiedLhs simplifiedRhs) $+        HashMap.map snd boolSimplEnv+      (renamedEnv, c') =+        shortenVarNames prunedEnv c { slhs = simplifiedLhs, srhs = simplifiedRhs }+      prettyEnv =+        sortOn bindingSelector $+        eraseUnusedBindings (constraintSymbols (slhs c') (srhs c')) renamedEnv+   in hang (text "\n\nconstraint:") 2 $+          text "lhs" <+> toFix (slhs c')+      $+$ text "rhs" <+> toFix (srhs c')+      $+$ pprId (sid c) <+> text "tag" <+> toFix (stag c)+      $+$ toFixMeta (text "constraint" <+> pprId (sid c)) (toFix (sinfo c))+      $+$ hang (text "environment:") 2+            (vcat $ intersperse "" $ elidedMessage : map prettyBind prettyEnv)+  where+    prettyBind (s, sr) = sep [toFix s <+> ":", nest 2 $ prettySortedRef sr]+    prettySortedRef sr = braces $ sep+      [ toFix (reftBind (sr_reft sr)) <+> ":" <+> toFix (sr_sort sr) <+> "|"+      , nest 2 $ toFix $ conjuncts $ reftPred $ sr_reft sr+      ]++    elidedMessage = "// elided some likely irrelevant bindings"++    constraintSymbols sr0 sr1 =+      HashSet.union (sortedReftSymbols sr0) (sortedReftSymbols sr1)++    -- Sort by symbol then reft+    bindingSelector (s, sr) =+      ( -- put unused symbols at the end+        if "_" `Text.isPrefixOf` s then "{" <> s else s+      , reftBind (sr_reft sr)+      , sr_sort sr+      , reftPred $ sr_reft sr+      )++pprId :: Show a => Maybe a -> Doc+pprId (Just i)  = "id" <+> text (show i)+pprId _         = ""++toFixMeta :: Doc -> Doc -> Doc+toFixMeta k v = text "// META" <+> k <+> text ":" <+> v++-- | @eraseUnusedBindings ss env@ prefixes with @_@ the symbols that aren't+-- refered from @ss@ or refinement types in the environment.+eraseUnusedBindings+  :: HashSet Symbol -> [(Symbol, SortedReft)] -> [(Text, SortedReft)]+eraseUnusedBindings ss env = map (first reachable) env+  where+    allSymbols = HashSet.union ss envSymbols+    envSymbols =+      HashSet.unions $+      map (exprSymbolsSet . reftPred . sr_reft . snd) env++    reachable s =+      if s `HashSet.member` allSymbols then+        symbolText s+      else+        "_" <> symbolText s++-- | Shortens the names of refinements types in a given environment+-- and constraint+shortenVarNames+  :: HashMap Symbol SortedReft+  -> SubC a+  -> ([(Symbol, SortedReft)], SubC a)+shortenVarNames env c =+  let bindsRenameMap = proposeRenamings $ HashMap.keys env+      env' = map (renameBind bindsRenameMap) (HashMap.toList env)+   in+      (env', renameSubC bindsRenameMap c)+  where+    renameSubC :: HashMap Symbol Symbol -> SubC a -> SubC a+    renameSubC symMap c =+      mkSubC+        (senv c)+        (renameSortedReft symMap $ slhs c)+        (renameSortedReft symMap $ srhs c)+        (sid c)+        (stag c)+        (sinfo c)++    renameBind+      :: HashMap Symbol Symbol -> (Symbol, SortedReft) -> (Symbol, SortedReft)+    renameBind symMap (s, sr) =+      (at symMap s, renameSortedReft symMap sr)++    renameSortedReft+      :: HashMap Symbol Symbol -> SortedReft -> SortedReft+    renameSortedReft symMap (RR t r) =+      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)+       in reft (at m (reftBind r)) $+            substSortInExpr sortSubst $+            (substf (EVar . (at m)) $ reftPred r)++    at :: HashMap Symbol Symbol -> Symbol -> Symbol+    at m k = fromMaybe k $ HashMap.lookup k m++-- | Given a list of symbols with no duplicates, it proposes shorter+-- names to use for them.+--+-- All proposals preserve the prefix of the original name. A prefix is+-- the longest substring containing the initial character and no separator+-- ## ('symSepName').+--+-- Suffixes are preserved, except when symbols with a given prefix always+-- use the same suffix.+--+proposeRenamings :: [Symbol] -> HashMap Symbol Symbol+proposeRenamings = toSymMap . toPrefixSuffixMap++-- | Indexes symbols by prefix and then by suffix. If the prefix+-- equals the symbol, then the suffix is the empty symbol.+--+-- For instance,+--+-- > toPrefixSuffixMap ["a##b##c"] ! "a" ! "c" == ["a##b##c"]+-- > toPrefixSuffixMap ["a"] ! "a" ! "" == ["a"]+--+-- In general,+--+-- > 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)+-- >     , (sfx, xs) <- toList m+-- >     ]+--+-- TODO: put the above in unit tests+--+toPrefixSuffixMap :: [Symbol] -> HashMap Symbol (HashMap Symbol [Symbol])+toPrefixSuffixMap xs = HashMap.fromListWith (HashMap.unionWith (++))+  [ (pfx, HashMap.singleton sfx [s])+  | s <- xs+  , let pfx = prefixOfSym s+        sfx = suffixOfSym $ dropPrefixOfSym s+  ]++-- | Suggests renamings for every symbol in a given prefix/suffix map.+toSymMap :: HashMap Symbol (HashMap Symbol [Symbol]) -> HashMap Symbol Symbol+toSymMap prefixMap = HashMap.fromList+  [ r+  | (pfx, h) <- HashMap.toList prefixMap+  , r <- renameWithSuffixes pfx (HashMap.toList h)+  ]+  where+    renameWithSuffixes pfx = \case+      [(_sfx, ss)] -> renameWithAppendages pfx ("", ss)+      sfxs -> concatMap (renameWithAppendages pfx) sfxs++    renameWithAppendages pfx (sfx, ss) = zip ss $ case ss of+      [_s] -> [pfx `suffixIfNotNull` sfx]+      ss -> zipWith (rename pfx sfx) [1..] ss++    rename pfx sfx i _s =+      pfx `suffixIfNotNull` sfx `suffixSymbol` symbol (show i)++    suffixIfNotNull a b =+      if Text.null (symbolText b) then a else a `suffixSymbol` b
src/Language/Fixpoint/Solver/Rewrite.hs view
@@ -1,11 +1,16 @@ {-# LANGUAGE DeriveGeneric             #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE ScopedTypeVariables       #-}  module Language.Fixpoint.Solver.Rewrite   ( getRewrite+  -- , getRewrite'   , subExprs   , unify+  , ordConstraints+  , convert+  , passesTerminationCheck   , RewriteArgs(..)   , RWTerminationOpts(..)   , SubExpr@@ -14,179 +19,28 @@  import           Control.Monad.State import           Control.Monad.Trans.Maybe-import           GHC.Generics-import           Data.Hashable 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           Language.Fixpoint.Types hiding (simplify) import qualified Data.Text as TX--type Op = Symbol-type OpOrdering = [Symbol]-data Term = Term Symbol [Term] deriving (Eq, Generic)-instance Hashable Term--termSym :: Term -> Symbol-termSym (Term s _) = s--instance Show Term where-  show (Term op [])   = TX.unpack $ symbolText op-  show (Term op args) =-    TX.unpack (symbolText op) ++ "(" ++ L.intercalate ", " (map show args) ++ ")"--data SCDir =-    SCUp-  | SCEq -  | SCDown-  deriving (Eq, Ord, Show, Generic)--instance Hashable SCDir+import           GHC.IO.Handle.Types (Handle)+import           Text.PrettyPrint (text)+import           Language.Fixpoint.Types hiding (simplify)+import           Language.REST+import           Language.REST.AbstractOC+import qualified Language.REST.RuntimeTerm as RT+import           Language.REST.Op+import           Language.REST.OrderingConstraints.ADT (ConstraintsADT) -type SCPath = ((Op, Int), (Op, Int), [SCDir]) type SubExpr = (Expr, Expr -> Expr) -data SCEntry = SCEntry {-    from :: (Op, Int)-  , to   :: (Op, Int)-  , dir  :: SCDir-} deriving (Eq, Ord, Show, Generic)+data TermOrigin = PLE | RW deriving (Show, Eq) -instance Hashable SCEntry+instance PPrint TermOrigin where+  pprintTidy _ = text . show -getDir :: OpOrdering -> Term -> Term -> SCDir-getDir o from to =-  case (synGTE o from to, synGTE o to from) of-      (True, True)  -> SCEq-      (True, False) -> SCDown-      (False, _)    -> SCUp -getSC :: OpOrdering -> Term -> Term -> S.HashSet SCEntry-getSC o (Term op ts) (Term op' us) = -  S.fromList $ do-    (i, from) <- zip [0..] ts-    (j, to)   <- zip [0..] us-    return $ SCEntry (op, i) (op', j) (getDir o from to)--scp :: OpOrdering -> [Term] -> S.HashSet SCPath-scp _ []       = S.empty-scp _ [_]      = S.empty-scp o [t1, t2] = S.fromList $ do-  (SCEntry a b d) <- S.toList $ getSC o t1 t2-  return (a, b, [d])-scp o (t1:t2:trms) = S.fromList $ do-  (SCEntry a b' d) <- S.toList $ getSC o t1 t2-  (a', b, ds)      <- S.toList $ scp o (t2:trms)-  guard $ b' == a'-  return (a, b, d:ds)--synEQ :: OpOrdering -> Term -> Term -> Bool-synEQ o l r = synGTE o l r && synGTE o r l--opGT :: OpOrdering -> Op -> Op -> Bool-opGT ordering op1 op2 = case (L.elemIndex op1 ordering, L.elemIndex op2 ordering) of-  (Just index1, Just index2) -> index1 < index2-  (Just _, Nothing)          -> True-  _                          -> False--removeSynEQs :: OpOrdering -> [Term] -> [Term] -> ([Term], [Term])-removeSynEQs _ [] ys      = ([], ys)-removeSynEQs ordering (x:xs) ys-  | Just yIndex <- L.findIndex (synEQ ordering x) ys-  = removeSynEQs ordering xs $ take yIndex ys ++ drop (yIndex + 1) ys-  | otherwise =-    let-      (xs', ys') = removeSynEQs ordering xs ys-    in-      (x:xs', ys')--synGTEM :: OpOrdering -> [Term] -> [Term] -> Bool-synGTEM ordering xs ys =     -  case removeSynEQs ordering xs ys of-    (_   , []) -> True-    (xs', ys') -> any (\x -> all (synGT ordering x) ys') xs'-    -synGT :: OpOrdering -> Term -> Term -> Bool-synGT o t1 t2 = synGTE o t1 t2 && not (synGTE o t2 t1)--synGTM :: OpOrdering -> [Term] -> [Term] -> Bool-synGTM o t1 t2 = synGTEM o t1 t2 && not (synGTEM o t2 t1)--synGTE :: OpOrdering -> Term -> Term -> Bool-synGTE ordering t1@(Term x tms) t2@(Term y tms') =-  if opGT ordering x y then-    synGTM ordering [t1] tms'-  else if opGT ordering y x then-    synGTEM ordering tms [t2]-  else-    synGTEM ordering tms tms'--subsequencesOfSize :: Int -> [a] -> [[a]]-subsequencesOfSize n xs = let l = length xs-                          in if n>l then [] else subsequencesBySize xs !! (l-n)- where-   subsequencesBySize [] = [[[]]]-   subsequencesBySize (x:xs) = let next = subsequencesBySize xs-                             in zipWith (++) ([]:next) (map (map (x:)) next ++ [[]])--data TermOrigin = PLE | RW OpOrdering deriving (Show, Eq)--data DivergeResult = Diverging | NotDiverging OpOrdering--fromRW :: TermOrigin -> Bool-fromRW (RW _) = True-fromRW PLE    = False--getOrdering :: TermOrigin -> Maybe OpOrdering-getOrdering (RW o) = Just o-getOrdering PLE    = Nothing--diverges :: Maybe Int -> [(Term, TermOrigin)] -> Term -> DivergeResult-diverges maxOrderingConstraints path term = go 0-  where-   path' = map fst path ++ [term]-   go n |    n > length syms'-          || n > Mb.fromMaybe (length syms') maxOrderingConstraints = Diverging-   go n = case L.find (not . diverges') (orderings' n) of-     Just ordering -> NotDiverging ordering-     Nothing       -> go (n + 1)-   ops (Term o xs) = o:concatMap ops xs-   syms'           = L.nub $ concatMap ops path'-   suggestedOrderings :: [OpOrdering]-   suggestedOrderings =-     reverse $ Mb.catMaybes $ map (getOrdering . snd) path-   orderings' n    =-     suggestedOrderings ++ concatMap L.permutations ((subsequencesOfSize n) syms')-   diverges' o     = divergesFor o path term--divergesFor :: OpOrdering -> [(Term, TermOrigin)] -> Term -> Bool-divergesFor o path term = any diverges' terms'-  where-    terms = map fst path ++ [term]-    lastRWIndex =-      Mb.fromMaybe 0 (fmap fst $ L.find (fromRW . snd . snd) $ reverse $ zip [1..] path) -    okTerms    = take lastRWIndex terms-    checkTerms = drop lastRWIndex terms-    terms' = L.subsequences checkTerms ++ do-      firstpart  <- L.tails okTerms-      secondpart <- L.inits checkTerms-      return $ firstpart ++ secondpart-    diverges' :: [Term] -> Bool-    diverges' trms' =-      if length trms' <= 1 || termSym (head trms') /= termSym (last trms') then-        False-      else-        any ascending (scp o trms') && all (not . descending) (scp o trms')-      -descending :: SCPath -> Bool-descending (a, b, ds) = a == b && L.elem SCDown ds && L.notElem SCUp ds--ascending :: SCPath -> Bool-ascending  (a, b, ds) = a == b && L.elem SCUp ds- data RWTerminationOpts =-    RWTerminationCheckEnabled (Maybe Int) -- # Of constraints to consider+    RWTerminationCheckEnabled   | RWTerminationCheckDisabled  data RewriteArgs = RWArgs@@ -194,64 +48,77 @@  , rwTerminationOpts  :: RWTerminationOpts  } -getRewrite :: RewriteArgs -> [(Expr, TermOrigin)] -> SubExpr -> AutoRewrite -> MaybeT IO (Expr, TermOrigin)-getRewrite rwArgs path (subE, toE) (AutoRewrite args lhs rhs) =+ordConstraints :: (Handle, Handle) -> AbstractOC (ConstraintsADT Op) Expr IO+ordConstraints solver = contramap convert (adtRPO solver)+++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+                       = RT.App (Op (symbolText fName)) $ map convert terms+convert (EVar s)       = RT.App (Op (symbolText s)) []+convert (PNot e)       = RT.App "$not" [ convert e ]+convert (PAnd es)      = RT.App "$and" $ map convert es+convert (POr es)       = RT.App "$or" $ map convert es+convert (PAtom s l r)  = RT.App (Op $ "$atom" `TX.append` (TX.pack . show) s) [convert l, convert r]+convert (EBin o l r)   = RT.App (Op $ "$ebin" `TX.append` (TX.pack . show) o) [convert l, convert r]+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 e              = error (show e)++passesTerminationCheck :: AbstractOC oc a IO -> RewriteArgs -> oc -> IO Bool+passesTerminationCheck aoc rwArgs c =+  case rwTerminationOpts rwArgs of+    RWTerminationCheckEnabled  -> isSat aoc c+    RWTerminationCheckDisabled -> return True++getRewrite ::+     AbstractOC oc Expr IO+  -> RewriteArgs+  -> oc+  -> SubExpr+  -> AutoRewrite+  -> MaybeT IO (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'-    guard $ all ( (/= expr') . fst) path-    mapM_ (check . subst su) exprs-    let termPath = map (\(t, o) -> (convert t, o)) path-    case rwTerminationOpts rwArgs of-      RWTerminationCheckEnabled maxConstraints ->-        case diverges maxConstraints termPath (convert expr') of-          NotDiverging opOrdering  ->-            return (expr', RW opOrdering)-          Diverging ->-            mzero-      RWTerminationCheckDisabled -> return (expr', RW [])+    mapM_ (checkSubst su) exprs+    return $ case rwTerminationOpts rwArgs of+      RWTerminationCheckEnabled ->+        let+          c' = refine aoc c subE subE'+        in+          (expr', c')+      RWTerminationCheckDisabled -> (expr', c)   where-    -    convert (EIte i t e) = Term "$ite" $ map convert [i,t,e]-    convert (EApp (EVar s) (EVar var))-      | dcPrefix `isPrefixOfSym` s-      = Term (symbol $ TX.concat [symbolText s, "$", symbolText var]) []-     -    convert e@(EApp{})    | (EVar fName, terms) <- splitEApp e-                          = Term fName $ map convert terms-    convert (EVar s)      = Term s []                  -    convert (PAnd es)     = Term "$and" $ map convert es-    convert (POr es)      = Term "$or" $ map convert es-    convert (PAtom s l r) = Term (symbol $ "$atom" ++ show s) [convert l, convert r]-    convert (EBin o l r)  = Term (symbol $ "$ebin" ++ show o) [convert l, convert r]-    convert (ECon c)      = Term (symbol $ "$econ" ++ show c) []-    convert e             = error (show e)-    -         check :: Expr -> MaybeT IO ()     check e = do       valid <- MaybeT $ Just <$> isRWValid rwArgs e       guard valid-      -    dcPrefix = "lqdc"      freeVars = [s | RR _ (Reft (s, _)) <- args ]-    exprs    = [e | RR _ (Reft (_, e)) <- args ]+    exprs    = [(s, e) | RR _ (Reft (s, e)) <- args ] +    checkSubst su (s, e) =+      do+        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++ subExprs :: Expr -> [SubExpr] subExprs e = (e,id):subExprs' e  subExprs' :: Expr -> [SubExpr]-subExprs' (EIte c lhs rhs)  = c'' ++ l'' ++ r''+subExprs' (EIte c lhs rhs)  = c''   where     c' = subExprs c-    l' = subExprs lhs-    r' = subExprs rhs     c'' = map (\(e, f) -> (e, \e' -> EIte (f e') lhs rhs)) c'-    l'' = map (\(e, f) -> (e, \e' -> EIte c (f e') rhs)) l'-    r'' = map (\(e, f) -> (e, \e' -> EIte c lhs (f e'))) r'-    + subExprs' (EBin op lhs rhs) = lhs'' ++ rhs''   where     lhs' = subExprs lhs@@ -279,14 +146,19 @@     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> PAtom op lhs (f e'))) rhs' --- subExprs' e@(EApp{}) = concatMap replace indexedArgs---   where---     (f, es)          = splitEApp e---     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))-      +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+      (f, es)          = splitEApp e+      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))+ subExprs' _ = []  unifyAll :: [Symbol] -> [Expr] -> [Expr] -> Maybe Subst@@ -305,6 +177,13 @@ unify freeVars template seenExpr = case (template, seenExpr) of   (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) ->
src/Language/Fixpoint/Solver/Sanitize.hs view
@@ -21,7 +21,7 @@ -- import           Language.Fixpoint.Defunctionalize  import qualified Language.Fixpoint.Misc                            as Misc import qualified Language.Fixpoint.Types                           as F-import           Language.Fixpoint.Types.Config (Config, allowHO)+import           Language.Fixpoint.Types.Config (Config) import qualified Language.Fixpoint.Types.Config as Cfg  import qualified Language.Fixpoint.Types.Errors                    as E import qualified Language.Fixpoint.Smt.Theories                    as Thy@@ -42,7 +42,8 @@ sanitize cfg =    -- banIllScopedKvars         --      Misc.fM dropAdtMeasures         --      >=>-             Misc.fM dropFuncSortedShadowedBinders+                     banIrregularData+         >=> Misc.fM dropFuncSortedShadowedBinders          >=> Misc.fM sanitizeWfC          >=> Misc.fM replaceDeadKvars          >=> Misc.fM (dropDeadSubsts . restrictKVarDomain)@@ -343,7 +344,17 @@ badCs :: Misc.ListNE (F.SimpC a, [F.Symbol]) -> E.Error badCs = E.catErrors . map (E.errFreeVarInConstraint . Misc.mapFst F.subcId) +--------------------------------------------------------------------------------+-- | check that every DataDecl is regular+--------------------------------------------------------------------------------+banIrregularData :: F.SInfo a -> SanitizeM (F.SInfo a)+banIrregularData fi = Misc.applyNonNull (Right fi) (Left . badDataDecl) bads+  where+    bads = F.checkRegular (F.ddecls fi )  +badDataDecl :: Misc.ListNE F.DataDecl -> E.Error+badDataDecl ds = E.catErrors [ E.errBadDataDecl d | d <- ds ]+ -------------------------------------------------------------------------------- -- | check that no qualifier has free variables --------------------------------------------------------------------------------@@ -388,40 +399,42 @@ --   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 (F.dLits si) (ts ++ ts')+symbolEnv cfg si = F.symEnv sEnv tEnv ds lits (ts ++ ts')   where     ts'          = applySorts ae'      ae'          = elaborate (F.atLoc E.dummySpan "symbolEnv") env0 (F.ae si)-    env0         = F.symEnv sEnv tEnv ds (F.dLits si) ts+    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)-    xts          = symbolSorts cfg si+    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)  symbolSorts :: Config -> F.GInfo c a -> [(F.Symbol, F.Sort)] symbolSorts cfg fi = either E.die id $ symbolSorts' cfg fi  symbolSorts' :: Config -> F.GInfo c a -> SanitizeM [(F.Symbol, F.Sort)]-symbolSorts' cfg fi  = (normalize . compact . (defs ++)) =<< bindSorts fi+symbolSorts' _cfg fi  = (normalize . compact . (defs ++)) =<< bindSorts fi   where     normalize       = fmap (map (unShadow txFun dm))     dm              = M.fromList defs     defs            = F.toListSEnv . F.gLits $ fi-    txFun           +    txFun       | True        = id-      | allowHO cfg = id-      | otherwise   = defuncSort  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) -defuncSort :: F.Sort -> F.Sort-defuncSort (F.FFunc {}) = F.funcSort-defuncSort t            = t+_defuncSort :: F.Sort -> F.Sort+_defuncSort (F.FFunc {}) = F.funcSort+_defuncSort t            = t  compact :: [(F.Symbol, F.Sort)] -> Either E.Error [(F.Symbol, F.Sort)] compact xts
src/Language/Fixpoint/Solver/Solution.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP               #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections     #-}@@ -12,6 +13,8 @@    -- * Lookup Solution   , lhsPred++  , nonCutsResult   ) where  import           Control.Parallel.Strategies@@ -38,7 +41,7 @@  -- DEBUG import Text.Printf (printf)--- import           Debug.Trace+-- import Debug.Trace (trace)   --------------------------------------------------------------------------------@@ -46,19 +49,42 @@ -------------------------------------------------------------------------------- init :: (F.Fixpoint a) => Config -> F.SInfo a -> S.HashSet F.KVar -> Sol.Solution ---------------------------------------------------------------------------------init cfg si ks = Sol.fromList senv mempty keqs [] mempty ebs xEnv+init cfg si ks_ = Sol.fromList senv mempty keqs [] mempty ebs xEnv   where-    keqs       = map (refine si qs genv) ws `using` parList rdeepseq-    qs         = F.quals si-    ws         = [ w | (k, w) <- M.toList (F.ws si), not (isGWfc w) , k `S.member` ks]+    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_       = mkQCluster qs_+    qs_        = F.quals si+    ws         = [ w | (k, w) <- M.toList (F.ws si), not (isGWfc w), k `S.member` ks ]+    ks         = {- trace ("init-ks-size" ++ show (S.size ks_)) $ -} ks_     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)]  ---------------------------------------------------------------------------------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+-- | [NOTE:qual-cluster] It is wasteful to perform instantiation *individually*+--   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+--   2. Refactor instK to use QCluster+--------------------------------------------------------------------------------++type QCluster = M.HashMap QCSig [Qualifier]++type QCSig = [F.QualParam]++mkQCluster :: [Qualifier] -> QCluster+mkQCluster = Misc.groupMap qualSig++qualSig :: Qualifier -> QCSig+qualSig q = [ p { F.qpSym = F.dummyName }  | p <- F.qParams q ] ++--------------------------------------------------------------------------------++refine :: F.SInfo a -> QCluster -> F.SEnv F.Sort -> F.WfC a -> (F.KVar, Sol.QBind)+refine fi qs genv w = refineK (allowHOquals fi) env qs (F.wrft w)   where     env             = wenv <> genv     wenv            = F.sr_sort <$> F.fromListSEnv (F.envCs (F.bs fi) (F.wenv w))@@ -69,7 +95,7 @@     notLit    = not . F.isLitSymbol . fst  -refineK :: Bool -> F.SEnv F.Sort -> [F.Qualifier] -> (F.Symbol, F.Sort, F.KVar) -> (F.KVar, Sol.QBind)+refineK :: Bool -> F.SEnv F.Sort -> QCluster -> (F.Symbol, F.Sort, F.KVar) -> (F.KVar, Sol.QBind) refineK ho env qs (v, t, k) = F.notracepp _msg (k, eqs')    where     eqs                     = instK ho env v t qs@@ -81,29 +107,65 @@       -> F.SEnv F.Sort       -> F.Symbol       -> F.Sort-      -> [F.Qualifier]+      -> QCluster        -> Sol.QBind ---------------------------------------------------------------------------------instK ho env v t = Sol.qb . unique . concatMap (instKQ ho env v t)-  where-    unique       = L.nubBy ((. Sol.eqPred) . (==) . Sol.eqPred)+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 +      , q         <- qs+  ] -instKQ :: Bool-       -> F.SEnv F.Sort-       -> F.Symbol-       -> F.Sort-       -> F.Qualifier-       -> [Sol.EQual]-instKQ ho env v t q = do -  (su0, qsu0, v0) <- candidates senv [(t, [v])] qp-  xs              <- match senv tyss [v0] (applyQP su0 qsu0 <$> qps) -  return           $ Sol.eQual q (F.notracepp msg (reverse xs))+unique :: [Sol.EQual] -> [Sol.EQual]+unique qs = M.elems $ M.fromList [ (Sol.eqPred q, q) | q <- qs ]++instKSig :: Bool+         -> F.SEnv F.Sort+         -> F.Symbol+         -> F.Sort+         -> QCSig +         -> [[F.Symbol]]+instKSig ho env v t qsig = do +  (su0, i0, qs0) <- candidatesP senv [(0, t, [v])] qp+  ixs       <- matchP senv tyss [(i0, qs0)] (applyQPP su0 <$> qps) +  -- return     $ F.notracepp msg (reverse ixs)+  ys        <- instSymbol tyss (tail $ reverse ixs) +  return (v:ys)   where-    msg        = "instKQ " ++ F.showpp (F.qName q) ++ F.showpp (F.qParams q)-    qp : qps   = F.qParams q-    tyss       = instCands ho env+    -- 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 +  where+    m = M.fromList [(i, ys) | (i,_,ys) <- tyss]+    go [] = +      return []+    go ((i,qp):is) = do +      y   <- M.lookupDefault [] i m+      qsu <- maybeToList (matchSym qp y)+      ys  <- go [ (i', applyQPSubst qsu  qp') | (i', qp') <- is]+      return (y:ys)++-- instKQ :: Bool+--        -> F.SEnv F.Sort+--        -> F.Symbol+--        -> F.Sort+--        -> F.Qualifier+--        -> [Sol.EQual]+-- instKQ ho env v t q = do +--   (su0, qsu0, v0) <- candidates senv [(t, [v])] qp+--   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)+--     qp : qps   = F.qParams q+--     tyss       = instCands ho env+--     senv       = (`F.lookupSEnvWithDistance` env)+ instCands :: Bool -> F.SEnv F.Sort -> [(F.Sort, [F.Symbol])] instCands ho env = filter isOk tyss   where@@ -111,35 +173,69 @@     isOk      = if ho then const True else isNothing . F.functionSort . fst     xts       = F.toListSEnv env -match :: So.Env -> [(F.Sort, [F.Symbol])] -> [F.Symbol] -> [F.QualParam] -> [[F.Symbol]]-match env tyss xs (qp : qps)-  = do (su, qsu, x) <- candidates env tyss qp-       match env tyss (x : xs) (applyQP su qsu <$> qps)-match _   _   xs []-  = 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) -                       }+type SortIdx = Int +matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] -> +          [[(SortIdx, QualPattern)]]+matchP env tyss = go+  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) +  }++-- match :: So.Env -> [(F.Sort, [F.Symbol])] -> [F.Symbol] -> [F.QualParam] -> [[F.Symbol]]+-- match env tyss xs (qp : qps)+--   = do (su, qsu, x) <- candidates env tyss qp+--        match env tyss (x : xs) (applyQP su qsu <$> qps)+-- match _   _   xs []+--   = 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) +--   }+ ---------------------------------------------------------------------------------candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam -           -> [(So.TVSubst, QPSubst, F.Symbol)]+candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam -> +               [(So.TVSubst, SortIdx, QualPattern)] ---------------------------------------------------------------------------------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)                                     +candidatesP env tyss x =+    [(su, idx, qPat) +        | (idx, t,_)  <- tyss+        , su          <- maybeToList (So.unifyFast mono env xt t)     ]   where     xt   = F.qpSort x+    qPat = F.qpPat  x     mono = So.isMono xt-    _msg = "candidates tyss :=" ++ F.showpp tyss ++ "tx := " ++ F.showpp xt+     -matchSym :: F.QualParam -> F.Symbol -> Maybe QPSubst -matchSym qp y' = case F.qpPat qp of++-- --------------------------------------------------------------------------------+-- 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)                                     +--     ]+--   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 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 @@ -147,7 +243,6 @@   where      y             =  F.tidySymbol y' - data QPSubst = NoSub | JustSub Int F.Symbol    applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern @@ -172,10 +267,17 @@ -------------------------------------------------------------------------------- -- | Predicate corresponding to LHS of constraint in current solution ---------------------------------------------------------------------------------lhsPred :: (F.Loc a) => F.BindEnv -> Sol.Solution -> F.SimpC a -> F.Expr-lhsPred be s c = F.notracepp _msg $ fst $ apply g s bs+{-# SCC lhsPred #-}+lhsPred+  :: (F.Loc a)+  => F.IBindEnv+  -> F.BindEnv+  -> Sol.Solution+  -> F.SimpC a+  -> F.Expr+lhsPred bindingsInSmt be s c = F.notracepp _msg $ fst $ apply g s bs   where-    g          = CEnv ci be bs (F.srcSpan c)+    g          = CEnv ci be bs (F.srcSpan c) bindingsInSmt     bs         = F.senv c     ci         = sid c     _msg       = "LhsPred for id = " ++ show (sid c) ++ " with SOLUTION = " ++ F.showpp s@@ -185,6 +287,10 @@   , ceBEnv :: !F.BindEnv   , ceIEnv :: !F.IBindEnv    , ceSpan :: !F.SrcSpan+    -- | These are the bindings that the smt solver knows about and can be+    -- referred as @EVar (bindSymbol <bindId>)@ instead of serializing them+    -- again.+  , ceBindingsInSmt :: !F.IBindEnv   }  instance F.Loc CombinedEnv where @@ -194,9 +300,12 @@ type ExprInfo    = (F.Expr, KInfo)  apply :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ExprInfo-apply g s bs      = (F.pAnd (pks:ps), kI)+apply g s bs      = (F.conj (pks:ps), kI)   -- see [NOTE: pAnd-SLOW]   where-    (pks, kI)     = applyKVars g s ks  +    -- Clear the "known" bindings for applyKVars, since it depends on+    -- using the fully expanded representation of the predicates to bind their+    -- variables with quantifiers.+    (pks, kI)     = applyKVars g {ceBindingsInSmt = F.emptyIBindEnv} s ks     (ps,  ks, _)  = envConcKVars g s bs  @@ -208,8 +317,10 @@     is              = F.elemsIBindEnv bs  lookupBindEnvExt :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> (F.Symbol, F.SortedReft)-lookupBindEnvExt g s i -  | Just p <- ebSol g s i = (x, sr { F.sr_reft = F.Reft (x, p) }) +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) @@ -245,15 +356,51 @@                             , yi `F.memberIBindEnv` ienv                  ]  applyKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> [F.KVSub] -> ExprInfo-applyKVars g s = mrExprInfos (applyKVar g s) F.pAnd mconcat+applyKVars g s = mrExprInfos (applyKVar g s) F.pAndNoDedup mconcat  applyKVar :: CombinedEnv -> 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.pAnd $ fst <$> Sol.qbPreds msg s (F.ksuSubst ksu) eqs, mempty) -- TODO: don't initialize kvars that have a hyp solution+  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 be s =+  let g = CEnv Nothing be F.emptyIBindEnv F.dummySpan F.emptyIBindEnv+   in M.mapWithKey (mkNonCutsExpr g) $ Sol.sHyp s+  where+    mkNonCutsExpr g k cs = F.pOr $ map (bareCubePred g s k) cs++-- | Produces a predicate from a constraint defining a kvar.+--+-- This is written in imitation of 'cubePred'. However, there are some+-- differences since the result of 'cubePred' is fed to the verification+-- pipeline and @bareCubePred@ is meant for human inspection.+--+-- 1) Only one existential quantifier is introduced at the top of the+--    expression.+-- 2) @bareCubePred@ doesn't elaborate the expression, so it avoids calling+--    'elabExist'. 'apply' is invoked to eliminate other kvars though, and+--    apply will invoke 'elabExist', so 'Liquid.Fixpoint.SortCheck.unElab'+--    might need to be called on the output to remove the elaboration.+-- 3) The expression is created from its defining constraints only, while+--    @cubePred@ does expect the caller to supply the substitution at a+--    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 g s k c =+  let bs = Sol.cuBinds c+      su = Sol.cuSubst c+      g' = addCEnv  g bs+      bs' = delCEnv s k bs+      yts = symSorts g bs'+      sEnv = F.seSort (Sol.sEnv s)+      (xts, psu) = substElim (Sol.sEnv s) sEnv g' k su+      (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 g s ksu hyp = F.pOr *** mconcatPlus $ unzip $ cubePred g s ksu <$> hyp @@ -299,7 +446,7 @@  cubePredExc g s ksu c bs' = (cubeP, extendKInfo kI (Sol.cuTag c))   where-    cubeP           = (xts, psu, elabExist sp s yts' (p' &.& psu') )+    cubeP           = (xts, psu, elabExist sp s yts' (F.pAndNoDedup [p', psu']) )     sp              = F.srcSpan g     yts'            = symSorts g bs'     g'              = addCEnv  g bs@@ -408,7 +555,7 @@ symSorts g bs = second F.sr_sort <$> F.envCs (ceBEnv g) bs  _noKvars :: F.Expr -> Bool-_noKvars = null . V.kvars+_noKvars = null . V.kvarsExpr  -------------------------------------------------------------------------------- -- | Information about size of formula corresponding to an "eliminated" KVar.
src/Language/Fixpoint/Solver/Solve.hs view
@@ -11,7 +11,7 @@ module Language.Fixpoint.Solver.Solve (solve, solverInfo) where  import           Control.Monad (when, filterM)-import           Control.Monad.State.Strict (lift)+import           Control.Monad.State.Strict (liftIO, modify, lift) import           Language.Fixpoint.Misc import qualified Language.Fixpoint.Misc            as Misc import qualified Language.Fixpoint.Types           as F@@ -32,6 +32,9 @@ import qualified Data.HashSet        as S -- 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.Instantiate (instantiate)  -------------------------------------------------------------------------------- solve :: (NFData a, F.Fixpoint a, Show a, F.Loc a) => Config -> F.SInfo a -> IO (F.Result (Integer, a))@@ -76,7 +79,20 @@ siKvars :: F.SInfo a -> S.HashSet F.KVar siKvars = S.fromList . M.keys . F.ws ++{-# SCC doPLE #-}+doPLE :: (F.Loc a) =>  Config -> F.SInfo a -> [F.SubcId] -> SolveM ()+doPLE cfg fi0 subcIds = do+  fi <- liftIO $ instantiate cfg fi0 (Just subcIds)+  modify $ update' 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 solve_ #-} solve_ :: (NFData a, F.Fixpoint a, F.Loc a)        => Config        -> F.SInfo a@@ -87,12 +103,21 @@ -------------------------------------------------------------------------------- solve_ cfg fi s0 ks wkl = do   let s1   = {-# SCC "sol-init" #-} S.init cfg fi ks-  let s2   = mappend s0 s1 -  -- let s3   = solveEbinds fi s2 -  s       <- {-# SCC "sol-refine" #-} refine s2 wkl-  res     <- {-# SCC "sol-result" #-} result cfg wkl s+  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+    return (s3, res0)+  res <- case resStatus res0 of+    Unsafe _ bads | not (noLazyPLE cfg) && rewriteAxioms cfg -> do+      doPLE cfg fi (map fst bads)+      sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do+        s4 <- {- SCC "sol-refine" #-} refine bindingsInSmt s3 wkl+        result bindingsInSmt cfg wkl s4+    _ -> return res0   st      <- stats-  let res' = {-# SCC "sol-tidy"   #-} tidyResult res+  let res' = {- SCC "sol-tidy"   #-} tidyResult res   return $!! (res', st)  --------------------------------------------------------------------------------@@ -100,7 +125,10 @@ --   ensure uniqueness with the original names in the given WF constraints. -------------------------------------------------------------------------------- tidyResult :: F.Result a -> F.Result a-tidyResult r = r { F.resSolution = tidySolution (F.resSolution r) }+tidyResult r = r+  { F.resSolution = tidySolution (F.resSolution r)+  , F.resNonCutsSolution = tidySolution (F.resNonCutsSolution r)+  }  tidySolution :: F.FixSolution -> F.FixSolution tidySolution = fmap tidyPred@@ -109,15 +137,21 @@ tidyPred = F.substf (F.eVar . F.tidySymbol)  ---------------------------------------------------------------------------------refine :: (F.Loc a) => Sol.Solution -> W.Worklist a -> SolveM Sol.Solution+{-# SCC refine #-}+refine+  :: (F.Loc a)+  => F.IBindEnv+  -> Sol.Solution+  -> W.Worklist a+  -> SolveM Sol.Solution ---------------------------------------------------------------------------------refine s w+refine bindingsInSmt s w   | Just (c, w', newScc, rnk) <- W.pop w = do      i       <- tickIter newScc-     (b, s') <- refineC i s c+     (b, s') <- refineC bindingsInSmt i s c      lift $ writeLoud $ refineMsg i c b rnk      let w'' = if b then W.push c w' else w'-     refine s' w''+     refine bindingsInSmt s' w''   | otherwise = return s   where     -- DEBUG@@ -127,13 +161,19 @@ --------------------------------------------------------------------------- -- | Single Step Refinement ----------------------------------------------- ----------------------------------------------------------------------------refineC :: (F.Loc a) => Int -> Sol.Solution -> F.SimpC a-        -> SolveM (Bool, Sol.Solution)+{-# SCC refineC #-}+refineC+  :: (F.Loc a)+  => F.IBindEnv+  -> Int+  -> Sol.Solution+  -> F.SimpC a+  -> SolveM (Bool, Sol.Solution) ----------------------------------------------------------------------------refineC _i s c+refineC bindingsInSmt _i s c   | null rhs  = return (False, s)   | otherwise = do be     <- getBinds-                   let lhs = S.lhsPred be s c+                   let lhs = S.lhsPred bindingsInSmt be s c                    kqs    <- filterValid (cstrSpan c) lhs rhs                    return  $ S.update s ks kqs   where@@ -160,24 +200,42 @@ -------------------------------------------------------------------------------- -- | Convert Solution into Result ---------------------------------------------- ---------------------------------------------------------------------------------result :: (F.Fixpoint a, F.Loc a, NFData a) => Config -> W.Worklist a -> Sol.Solution-       -> SolveM (F.Result (Integer, a))+{-# SCC result #-}+result+  :: (F.Fixpoint a, F.Loc a, NFData a)+  => F.IBindEnv+  -> Config+  -> W.Worklist a+  -> Sol.Solution+  -> SolveM (F.Result (Integer, a)) ---------------------------------------------------------------------------------result cfg wkl s = do-  lift $ writeLoud "Computing Result"-  stat    <- result_ cfg wkl s-  lift $ whenLoud $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat)+result bindingsInSmt cfg wkl s =+  sendConcreteBindingsToSMT bindingsInSmt $ \bindingsInSmt2 -> do+    lift $ writeLoud "Computing Result"+    stat    <- result_ bindingsInSmt2 cfg wkl s+    lift $ whenLoud $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat) -  F.Result (ci <$> stat) <$> solResult cfg s <*> return mempty+    F.Result (ci <$> stat) <$> solResult cfg s <*> solNonCutsResult s <*> return mempty   where     ci c = (F.subcId c, F.sinfo c)  solResult :: Config -> Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr) solResult cfg = minimizeResult cfg . Sol.result -result_ :: (F.Loc a, NFData a) => Config -> W.Worklist a -> Sol.Solution -> SolveM (F.FixResult (F.SimpC a))-result_  cfg w s = do-  filtered <- filterM (isUnsat s) cs+solNonCutsResult :: Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr)+solNonCutsResult s = do+  be <- getBinds+  return $ S.nonCutsResult be s++result_+  :: (F.Loc a, NFData a)+  => F.IBindEnv+  -> Config+  -> W.Worklist a+  -> Sol.Solution+  -> SolveM (F.FixResult (F.SimpC a))+result_ bindingsInSmt cfg w s = do+  filtered <- filterM (isUnsat bindingsInSmt s) cs   sts      <- stats   pure $ res sts filtered   where@@ -217,13 +275,14 @@                               else go ps (p:acc)  ---------------------------------------------------------------------------------isUnsat :: (F.Loc a, NFData a) => Sol.Solution -> F.SimpC a -> SolveM Bool+isUnsat+  :: (F.Loc a, NFData a) => F.IBindEnv -> Sol.Solution -> F.SimpC a -> SolveM Bool ---------------------------------------------------------------------------------isUnsat s c = do+isUnsat bindingsInSmt s c = do   -- lift   $ printf "isUnsat %s" (show (F.subcId c))   _     <- tickIter True -- newScc   be    <- getBinds-  let lp = S.lhsPred be s c+  let lp = S.lhsPred bindingsInSmt be s c   let rp = rhsPred        c   res   <- not <$> isValid (cstrSpan c) lp rp   lift   $ whenLoud $ showUnsat res (F.subcId c) lp rp
src/Language/Fixpoint/Solver/Stats.hs view
@@ -10,8 +10,9 @@ import           Data.Serialize                (Serialize (..)) import           GHC.Generics import           Text.PrettyPrint.HughesPJ (text)-import qualified Data.Binary              as B+import qualified Data.Store              as S import qualified Language.Fixpoint.Types.PrettyPrint as F+import Data.Aeson  #if !MIN_VERSION_base(4,14,0) import           Data.Semigroup            (Semigroup (..))@@ -26,7 +27,7 @@   } deriving (Data, Show, Generic, Eq)  instance NFData Stats-instance B.Binary Stats+instance S.Store Stats instance Serialize Stats  instance F.PTable Stats where@@ -45,6 +46,12 @@           , numChck      = numChck s1      + numChck s2           , numVald      = numVald s1      + numVald s2           }++instance ToJSON Stats where+  toJSON = genericToJSON defaultOptions+  toEncoding = genericToEncoding defaultOptions++instance FromJSON Stats  instance Monoid Stats where   mempty  = Stats 0 0 0 0 0
src/Language/Fixpoint/Solver/TrivialSort.hs view
@@ -92,7 +92,7 @@ -------------------------------------------------------------------- updTI :: Polarity -> SortedReft -> TrivInfo -> TrivInfo ---------------------------------------------------------------------updTI p (RR t r) = addKVs t (kvars r) . addNTS p r t+updTI p (RR t r) = addKVs t (kvarsExpr $ reftPred r) . addNTS p r t  addNTS :: Polarity -> Reft -> Sort -> TrivInfo -> TrivInfo addNTS p r t ti
src/Language/Fixpoint/Solver/UniqifyBinds.hs view
@@ -25,12 +25,12 @@ -------------------------------------------------------------------------------- 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   --------------------------------------------------------------------------------
src/Language/Fixpoint/SortCheck.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PatternGuards         #-} {-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE RankNTypes            #-}  -- | This module has the functions that perform sort-checking, and related -- operations on Fixpoint expressions and predicates.@@ -49,7 +50,7 @@   -- * Sort-Directed Transformations   , Elaborate (..)   , applySorts-  , unElab, unApplyAt+  , unElab, unElabSortedReft, unApplyAt   , toInt    -- * Predicates on Sorts@@ -60,11 +61,13 @@   ) where  --  import           Control.DeepSeq+import           Control.Exception (Exception, catch, try, throwIO) import           Control.Monad import           Control.Monad.Except      -- (MonadError(..))-import           Control.Monad.State.Strict+import           Control.Monad.Reader  import qualified Data.HashMap.Strict       as M+import           Data.IORef import qualified Data.List                 as L import           Data.Maybe                (mapMaybe, fromMaybe, catMaybes, isJust) #if !MIN_VERSION_base(4,14,0)@@ -80,8 +83,23 @@ import           Text.PrettyPrint.HughesPJ.Compat import           Text.Printf --- import Debug.Trace+import           GHC.Stack+import qualified Language.Fixpoint.Types as F+import           System.IO.Unsafe (unsafePerformIO) +--import Debug.Trace as Debug++-- If set to 'True', enable precise logging via CallStacks.+debugLogs :: Bool+debugLogs = False++traced :: HasCallStack => (HasCallStack => String) -> String+traced str =+  if debugLogs+    then let prettified = prettyCallStack (popCallStack callStack)+         in str <> " (at " <> prettified <> ")"+    else str+ -------------------------------------------------------------------------------- -- | Predicates on Sorts ------------------------------------------------------- --------------------------------------------------------------------------------@@ -160,7 +178,7 @@   elaborate msg env xs = elaborate msg env <$> xs  elabNumeric :: Expr -> Expr-elabNumeric = Vis.mapExpr go+elabNumeric = Vis.mapExprOnExpr go   where     go (ETimes e1 e2)       | exprSort "txn1" e1 == FReal@@ -194,12 +212,14 @@ elabExpr :: Located String -> SymEnv -> Expr -> Expr elabExpr msg env e = case elabExprE msg env e of    Left ex  -> die ex -  Right e' -> e' +  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 e   -> Left  $ err (srcSpan e) (d (val e))+    Left (ChError f) ->+      let e = f ()+       in Left $ err (srcSpan e) (d (val e))     Right s  -> Right (fst s)   where     sEnv = seSort env@@ -235,7 +255,7 @@     step (PExist bs p)    = PExist bs (go p)     step (PAll   bs p)    = PAll   bs (go p)     step (PAtom r e1 e2)  = PAtom r (go e1) (go e2)-    step e@(EApp {})      = go e+    step e@EApp {}        = go e     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)@@ -251,7 +271,7 @@ -------------------------------------------------------------------------------- sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort sortExpr l γ e = case runCM0 l (checkExpr f e) of-    Left  e -> die $ err l (d (val e))+    Left (ChError f) -> die $ err l (d (val (f ())))     Right s -> s   where     f   = (`lookupSEnvWithDistance` γ)@@ -283,10 +303,19 @@ --------------------------------------------------------------------------------  -- | Types used throughout checker-type CheckM   = StateT ChState (Either ChError)-type ChError  = Located String-data ChState  = ChS { chCount :: Int, chSpan :: SrcSpan }+type CheckM = ReaderT ChState IO +-- We guard errors with a lambda to prevent accidental eager+-- evaluation of the payload. This module is using -XStrict.+-- See also Note [Lazy error messages].+newtype ChError  = ChError (() -> Located String)++instance Show ChError where+  show (ChError f) = show (f ())+instance Exception ChError where++data ChState = ChS { chCount :: IORef Int, chSpan :: SrcSpan }+ type Env      = Symbol -> SESearch Sort type ElabEnv  = (SymEnv, Env) @@ -298,18 +327,29 @@  -- withError :: CheckM a -> ChError -> CheckM a -- act `withError` e' = act `catchError` (\e -> throwError (atLoc e (val e ++ "\n  because\n" ++ val e')))- -withError :: CheckM a -> String -> CheckM a-act `withError` msg = act `catchError` (\e -> throwError (atLoc e (val e ++ "\n  because\n" ++ msg)))- ++withError :: HasCallStack => CheckM a -> String -> CheckM a+act `withError` msg = do+  r <- ask+  liftIO $ runReaderT act r `catch`+    (\(ChError f) ->+      throwIO $ ChError $ \_ ->+        let e = f ()+         in (atLoc e (val e ++ "\n  because\n" ++ msg))+    )+ runCM0 :: SrcSpan -> CheckM a -> Either ChError a-runCM0 sp act = fst <$> runStateT act (ChS 42 sp)+runCM0 sp act = unsafePerformIO $ do+  rn <- newIORef 42+  try (runReaderT act (ChS rn sp))  fresh :: CheckM Int fresh = do-  !n <- gets chCount-  modify $ \s -> s { chCount = 1 + chCount s }-  return n+  rn <- asks chCount+  liftIO $ do+    n <- readIORef rn+    writeIORef rn (n + 1)+    return n  -------------------------------------------------------------------------------- -- | Checking Refinements ------------------------------------------------------@@ -324,7 +364,7 @@ checkSortedReftFull :: Checkable a => SrcSpan -> SEnv SortedReft -> a -> Maybe Doc checkSortedReftFull sp γ t =    case runCM0 sp (check γ' t) of-    Left e  -> Just (text (val e))+    Left (ChError f)  -> Just (text (val (f ())))     Right _ -> Nothing   where     γ' = sr_sort <$> γ@@ -332,7 +372,7 @@ checkSortFull :: Checkable a => SrcSpan -> SEnv SortedReft -> Sort -> a -> Maybe Doc checkSortFull sp γ s t =    case runCM0 sp (checkSort γ' s t) of-    Left e  -> Just (text (val e))+    Left (ChError f)  -> Just (text (val (f ())))     Right _ -> Nothing   where       γ' = sr_sort <$> γ@@ -340,7 +380,7 @@ checkSorted :: Checkable a => SrcSpan -> SEnv Sort -> a -> Maybe Doc checkSorted sp γ t =    case runCM0 sp (check γ t) of-    Left e   -> Just (text (val e))+    Left (ChError f)  -> Just (text (val (f ())))     Right _  -> Nothing  pruneUnsortedReft :: SEnv Sort -> Templates -> SortedReft -> SortedReft@@ -426,6 +466,7 @@ -------------------------------------------------------------------------------- -- | Elaborate expressions with types to make polymorphic instantiation explicit. --------------------------------------------------------------------------------+{-# SCC elab #-} elab :: ElabEnv -> Expr -> CheckM (Expr, Sort) -------------------------------------------------------------------------------- elab f@(_, g) e@(EBin o e1 e2) = do@@ -471,10 +512,18 @@   (e', s) <- elab f e   return (ENeg e', s) +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)+  s         <- checkIteTy g p e1' e2' s1 s2+  return (EIte p' (cast e1' s) (cast e2' s), t)+ elab f@(_,g) (EIte p e1 e2) = do+  t <- getIte g e1 e2    (p', _)   <- elab f p-  (e1', s1) <- elab f e1-  (e2', s2) <- elab f e2+  (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) @@ -510,7 +559,9 @@   (t1',t2') <- unite g e  t1 t2 `withError` (errElabExpr e)   e1'       <- elabAs f t1' e1   e2'       <- elabAs f t2' e2-  return (PAtom eq (ECst e1' t1') (ECst e2' t2') , boolSort)+  e1''      <- eCstAtom f e1' t1'+  e2''      <- eCstAtom f e2' t2'+  return (PAtom eq  e1'' e2'' , boolSort)  elab f (PAtom r e1 e2)   | r == Ueq || r == Une = do@@ -547,6 +598,21 @@ elab _ (ETAbs _ _) =   error "SortCheck.elab: TODO: implement ETAbs" ++-- | 'eCstAtom' is to support tests like `tests/pos/undef00.fq`+eCstAtom :: ElabEnv -> Expr -> Sort -> CheckM Expr+eCstAtom f@(sym,g) (EVar x) t +  | Found s <- g x+  , 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 +  (is, FVar j) -> j `elem` is+  _            -> False++ elabAddEnv :: Eq a => (t, a -> SESearch b) -> [(a, b)] -> (t, a -> SESearch b) elabAddEnv (g, f) bs = (g, addEnv f bs) @@ -559,7 +625,6 @@   where     _msg  = "elabAs: t = " ++ showpp t ++ " e = " ++ showpp e     go (EApp e1 e2)   = elabAppAs f t e1 e2-    -- go (EIte b e1 e2) = EIte b <$> go e1 <*> go e2     go e              = fst    <$> elab f e  -- DUPLICATION with `checkApp'`@@ -580,15 +645,15 @@ elabEApp f@(_, g) e1 e2 = do   (e1', s1)     <- notracepp ("elabEApp1: e1 = " ++ showpp e1) <$> elab f e1   (e2', s2)     <- elab f e2-  (s1', s2', s) <- elabAppSort g e1 e2 s1 s2-  return           (e1', s1', e2', s2', s)+  (e1'', e2'', s1', s2', s) <- elabAppSort g e1' e2' s1 s2+  return           (e1'', s1', e2'', s2', s) -elabAppSort :: Env -> Expr -> Expr -> Sort -> Sort -> CheckM (Sort, Sort, Sort)+elabAppSort :: Env -> Expr -> Expr -> Sort -> Sort -> CheckM (Expr, Expr, Sort, Sort, Sort) elabAppSort f e1 e2 s1 s2 = do   let e            = Just (EApp e1 e2)   (sIn, sOut, su) <- checkFunSort s1   su'             <- unify1 f e su sIn s2-  return           $ (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)   --------------------------------------------------------------------------------@@ -638,10 +703,13 @@ toIntAt :: Sort -> Expr toIntAt s = ECst (EVar toIntName) (FFunc s FInt) -unElab :: (Vis.Visitable t) => t -> t+unElab :: Expr -> Expr unElab = Vis.stripCasts . unApply -unApply :: (Vis.Visitable t) => t -> t+unElabSortedReft :: SortedReft -> SortedReft+unElabSortedReft sr = sr { sr_reft = mapPredReft unElab (sr_reft sr) }++unApply :: Expr -> Expr unApply = Vis.trans (Vis.defaultVisitor { Vis.txExpr = const go }) () ()   where     go (ECst (EApp (EApp f e1) e2) _)@@ -816,10 +884,17 @@   return (apply su t1, apply su t2)  throwErrorAt :: String -> CheckM a -throwErrorAt err = do -  sp <- gets chSpan -  throwError (atLoc sp err)+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)) +-- Note [Lazy error messages]+--+-- We don't want to construct error messages early, or+-- we might trigger some expensive computation of editDistance+-- when no error has actually occurred yet.+ -- | Helper for checking symbol occurrences checkSym :: Env -> Symbol -> CheckM Sort checkSym f x = case f x of@@ -834,6 +909,12 @@   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 +  (`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)@@ -908,9 +989,9 @@ checkOpTy _ _ FReal FInt   = return FReal -checkOpTy f _ t t'-  | t == t'-  = checkNumeric f t >> return t+checkOpTy f e t t'+  | Just s <- unify f (Just e) t t'+  = checkNumeric f (apply s t) >> return (apply s t)  checkOpTy _ e t t'   = throwErrorAt (errOp e t t')@@ -950,7 +1031,7 @@   | otherwise     = throwErrorAt (errBoolSort e s)  -- | Checking Relations-checkRel :: Env -> Brel -> Expr -> Expr -> CheckM ()+checkRel :: HasCallStack => Env -> Brel -> Expr -> Expr -> CheckM () checkRel f Eq e1 e2 = do   t1 <- checkExpr f e1   t2 <- checkExpr f e2@@ -993,6 +1074,7 @@ -- | Sort Unification on Expressions -------------------------------------------------------------------------------- +{-# SCC unifyExpr #-} unifyExpr :: Env -> Expr -> Maybe TVSubst unifyExpr f (EApp e1 e2) = Just $ mconcat $ catMaybes [θ1, θ2, θ]   where@@ -1017,6 +1099,7 @@ -------------------------------------------------------------------------------- -- | Sort Unification --------------------------------------------------------------------------------+{-# SCC unify #-} unify :: Env -> Maybe Expr -> Sort -> Sort -> Maybe TVSubst -------------------------------------------------------------------------------- unify f e t1 t2@@ -1058,21 +1141,41 @@ -------------------------------------------------------------------------------- unifyFast :: Bool -> Env -> Sort -> Sort -> Maybe TVSubst ---------------------------------------------------------------------------------unifyFast False f = unify f Nothing-unifyFast True  _ = uMono-  where-    uMono t1 t2-     | t1 == t2   = Just emptySubst-     | otherwise  = Nothing+unifyFast False f t1 t2 = unify f Nothing t1 t2+unifyFast True  _ t1 t2+  | t1 == t2        = Just emptySubst+  | otherwise           = Nothing +{-+eqFast :: Sort -> Sort -> Bool+eqFast = go +  where +    go FAbs {} _       = False+    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 +                          FApp t1 t2 ->  go s1 t1 && go s2 t2+                          _ -> False +    go (FTC s1) t      = case t of +                            FTC t1 -> s1 == t1+                            _ -> False+    +    go FInt FInt           = True+    go FReal FReal         = True+    go FNum FNum           = True+    go FFrac FFrac         = True+    go (FVar i1) (FVar i2) = i1 == i2+    go _ _                 = False + -}  ---------------------------------------------------------------------------------unifys :: Env -> Maybe Expr -> [Sort] -> [Sort] -> CheckM TVSubst+unifys :: HasCallStack => Env -> Maybe Expr -> [Sort] -> [Sort] -> CheckM TVSubst -------------------------------------------------------------------------------- unifys f e = unifyMany f e emptySubst -unifyMany :: Env -> Maybe Expr -> TVSubst -> [Sort] -> [Sort] -> CheckM TVSubst+unifyMany :: HasCallStack => Env -> Maybe Expr -> TVSubst -> [Sort] -> [Sort] -> CheckM TVSubst unifyMany f e θ ts ts'   | length ts == length ts' = foldM (uncurry . unify1 f e) θ $ zip ts ts'   | otherwise               = throwErrorAt (errUnifyMany ts ts')@@ -1183,7 +1286,7 @@  applyExpr :: Maybe TVSubst -> Expr -> Expr applyExpr Nothing e  = e-applyExpr (Just θ) e = Vis.mapExpr f e+applyExpr (Just θ) e = Vis.mapExprOnExpr f e   where     f (ECst e s) = ECst e (apply θ s)     f e          = e@@ -1224,6 +1327,7 @@  lookupVar :: Int -> TVSubst -> Maybe Sort lookupVar i (Th m)   = M.lookup i m+{-# SCC lookupVar #-}  updateVar :: Int -> Sort -> TVSubst -> TVSubst updateVar !i !t (Th m) = Th (M.insert i t m)@@ -1256,8 +1360,9 @@ errUnifyMany ts ts'  = printf "Cannot unify types with different cardinalities %s and %s"                          (showpp ts) (showpp ts') -errRel :: Expr -> Sort -> Sort -> String-errRel e t1 t2       = printf "Invalid Relation %s with operand types %s and %s"+errRel :: HasCallStack => Expr -> Sort -> Sort -> String+errRel e t1 t2       =+  traced $ printf "Invalid Relation %s with operand types %s and %s"                          (showpp e) (showpp t1) (showpp t2)  errOp :: Expr -> Sort -> Sort -> String
+ src/Language/Fixpoint/Types/Binary.hs view
@@ -0,0 +1,8 @@+-- | 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+
src/Language/Fixpoint/Types/Config.hs view
@@ -89,10 +89,16 @@   , rewriteAxioms    :: Bool           -- ^ Allow axiom instantiation via rewriting   , 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    , extensionality   :: Bool           -- ^ Enable extensional interpretation of function equality-  , maxRWOrderingConstraints :: Maybe Int-  , rwTerminationCheck     :: Bool+  , rwTerminationCheck  :: Bool        -- ^ Enable termination checking for rewriting+  , 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)   } deriving (Eq,Data,Typeable,Show,Generic)  instance Default Config where@@ -179,10 +185,25 @@   , rewriteAxioms            = False &= help "allow axiom instantiation via rewriting"   , oldPLE                   = False &= help "Use old version of PLE"   , noIncrPle                = False &= help "Don't use incremental PLE"+  , noEnvironmentReduction   =+      False+        &= name "no-environment-reduction"+        &= help "Don't perform environment reduction"+  , inlineANFBindings        =+      False+        &= name "inline-anf-bindings"+        &= help (unwords+          [ "Inline ANF bindings."+          , "Sometimes improves performance and sometimes worsens it."+          , "Disabled by --no-environment-reduction"+          ])   , checkCstr                = []    &= help "Only check these specific constraint-ids"    , extensionality           = False &= help "Allow extensional interpretation of extensionality"-  , maxRWOrderingConstraints = Nothing &= help "Maximum number of functions to consider in rewrite orderings"   , rwTerminationCheck       = False   &= help "Disable 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"   }   &= verbosity   &= program "fixpoint"@@ -198,12 +219,13 @@ config = cmdArgsMode defConfig  getOpts :: IO Config-getOpts = do md <- cmdArgs defConfig-             putStrLn banner-             return md+getOpts = do +  md <- cmdArgs defConfig+  whenNormal (putStrLn banner)+  return md  banner :: String-banner =  "\n\nLiquid-Fixpoint Copyright 2013-15 Regents of the University of California.\n"+banner =  "\n\nLiquid-Fixpoint Copyright 2013-21 Regents of the University of California.\n"        ++ "All Rights Reserved.\n"  multicore :: Config -> Bool
src/Language/Fixpoint/Types/Constraints.hs view
@@ -19,6 +19,7 @@    -- * Top-level Queries     FInfo, SInfo, GInfo (..), FInfoWithOpts(..)   , convertFormat+  , sinfoToFInfo   , Solver     -- * Serializing@@ -32,7 +33,7 @@   -- * Constraints   , WfC (..), isGWfc, updateWfCExpr   , SubC, SubcId-  , mkSubC, subcId, sid, senv, slhs, srhs, stag, subC, wfC+  , mkSubC, subcId, sid, senv, updateSEnv, slhs, srhs, stag, subC, wfC   , SimpC (..)   , Tag   , TaggedC, clhs, crhs@@ -78,6 +79,7 @@   , mkEquation   , Rewrite  (..)   , AutoRewrite (..)+  , dedupAutoRewrites    -- * Misc  [should be elsewhere but here due to dependencies]   , substVars@@ -85,12 +87,14 @@   , gSorts   ) where -import qualified Data.Binary as B+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 import           GHC.Generics              (Generic)@@ -115,6 +119,8 @@ import           Text.PrettyPrint.HughesPJ.Compat import qualified Data.HashMap.Strict       as M import qualified Data.HashSet              as S+import qualified Data.ByteString           as B+import qualified Data.Binary as B  -------------------------------------------------------------------------------- -- | Constraints ---------------------------------------------------------------@@ -221,6 +227,7 @@  class TaggedC c a where   senv  :: c a -> IBindEnv+  updateSEnv  :: c a -> (IBindEnv -> IBindEnv) -> c a   sid   :: c a -> Maybe Integer   stag  :: c a -> Tag   sinfo :: c a -> a@@ -229,6 +236,7 @@  instance TaggedC SimpC a where   senv      = _cenv+  updateSEnv c f = c { _cenv = f (_cenv c) }   sid       = _cid   stag      = _ctag   sinfo     = _cinfo@@ -237,6 +245,7 @@  instance TaggedC SubC a where   senv      = _senv+  updateSEnv c f = c { _senv = f (_senv c) }   sid       = _sid   stag      = _stag   sinfo     = _sinfo@@ -269,19 +278,26 @@ data Result a = Result    { resStatus    :: !(FixResult a)   , resSolution  :: !FixSolution+  , resNonCutsSolution :: !FixSolution   , gresSolution :: !GFixSolution    }   deriving (Generic, Show, Functor) +++instance ToJSON a => ToJSON (Result a) where+  toJSON = toJSON . resStatus+ instance Semigroup (Result a) where-  r1 <> r2  = Result stat soln gsoln+  r1 <> r2  = Result stat soln nonCutsSoln gsoln     where       stat  = (resStatus r1)    <> (resStatus r2)       soln  = (resSolution r1)  <> (resSolution r2)+      nonCutsSoln = resNonCutsSolution r1 <> resNonCutsSolution r2       gsoln = (gresSolution r1) <> (gresSolution r2)  instance Monoid (Result a) where-  mempty        = Result mempty mempty mempty+  mempty        = Result mempty mempty mempty mempty   mappend       = (<>)  unsafe, safe :: Result a@@ -289,8 +305,9 @@ safe   = mempty {resStatus = Safe mempty}  isSafe :: Result a -> Bool-isSafe (Result (Safe _) _ _) = True-isSafe _                     = False+isSafe r = case resStatus r of+  Safe{} -> True+  _ -> False  isUnsafe :: Result a -> Bool isUnsafe r | Unsafe _ _ <- resStatus r@@ -373,17 +390,17 @@   show = showpp  -----------------------------------------------------------------instance B.Binary QualPattern -instance B.Binary QualParam -instance B.Binary Qualifier-instance B.Binary Kuts-instance B.Binary HOInfo-instance B.Binary GWInfo-instance B.Binary GFixSolution-instance (B.Binary a) => B.Binary (SubC a)-instance (B.Binary a) => B.Binary (WfC a)-instance (B.Binary a) => B.Binary (SimpC a)-instance (B.Binary (c a), B.Binary a) => B.Binary (GInfo c a)+instance S.Store QualPattern +instance S.Store QualParam +instance S.Store Qualifier+instance S.Store Kuts+instance S.Store HOInfo+instance S.Store GWInfo+instance S.Store GFixSolution+instance (S.Store a) => S.Store (SubC a)+instance (S.Store a) => S.Store (WfC a)+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 @@ -404,6 +421,9 @@ instance Hashable QualParam instance Hashable Equation +instance B.Binary QualPattern+instance B.Binary QualParam+instance B.Binary Qualifier  --------------------------------------------------------------------------- -- | "Smart Constructors" for Constraints ---------------------------------@@ -469,21 +489,21 @@   , qBody   :: !Expr       -- ^ Predicate   , qPos    :: !SourcePos  -- ^ Source Location   }-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving (Eq, Ord, Show, Data, Typeable, Generic)  data QualParam = QP    { qpSym  :: !Symbol   , qpPat  :: !QualPattern    , qpSort :: !Sort   } -  deriving (Eq, Show, Data, Typeable, Generic)+  deriving (Eq, Ord, Show, Data, Typeable, Generic)  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'-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving (Eq, Ord, Show, Data, Typeable, Generic)  trueQual :: Qualifier trueQual = Q (symbol ("QTrue" :: String)) [] mempty (dummyPos "trueQual")@@ -611,7 +631,7 @@                deriving (Eq, Show, Generic)  instance Fixpoint Kuts where-  toFix (KS s) = vcat $ (("cut " <->) . toFix) <$> 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@@ -771,15 +791,15 @@     cfgDoc cfg    = text ("// " ++ show cfg)     gConDoc       = sEnvDoc "constant"             . gLits     dConDoc       = sEnvDoc "distinct"             . dLits-    csDoc         = vcat     . map toFix . M.elems . cm-    wsDoc         = vcat     . map toFix . M.elems . ws+    csDoc         = vcat     . map (toFix . snd) . hashMapToAscList . cm+    wsDoc         = vcat     . map toFix . L.sortOn (thd3 . wrft) . M.elems . ws     kutsDoc       = toFix    . kuts     -- packsDoc      = toFix    . packs-    declsDoc      = vcat     . map ((text "data" <+>) . toFix) . ddecls+    declsDoc      = vcat     . map ((text "data" <+>) . toFix) . L.sort . ddecls     (ubs, ebs)    = splitByQuantifiers (bs x') (ebinds x')     bindsDoc      = toFix    ubs                $++$ toFix    ebs-    qualsDoc      = vcat     . map toFix . quals+    qualsDoc      = vcat     . map toFix . L.sort . quals     aeDoc         = toFix    . ae     metaDoc (i,d) = toFixMeta (text "bind" <+> toFix i) (toFix d)     mdata         = metadata cfg@@ -791,7 +811,7 @@ x $++$ y = x $+$ text "\n" $+$ y  sEnvDoc :: Doc -> SEnv Sort -> Doc-sEnvDoc d       = vcat . map kvD . toListSEnv+sEnvDoc d       = vcat . map kvD . L.sortOn fst . toListSEnv   where     kvD (c, so) = d <+> toFix c <+> ":" <+> parens (toFix so) @@ -830,27 +850,51 @@  type BindM = M.HashMap Integer BindId +sinfoToFInfo :: SInfo a -> FInfo a+sinfoToFInfo fi = fi+  { bs = envWithoutLhss+  , cm = simpcToSubc (bs fi) <$> cm fi+  }+  where+    envWithoutLhss =+      M.foldl' (\m c -> deleteBindEnv (cbind c) m) (bs fi) (cm fi)++-- 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 env s = SubC+  { _senv  = deleteIBindEnv (cbind s) (senv s)+  , slhs   = sr+  , srhs   = RR (sr_sort sr) (Reft (b, _crhs s))+  , _sid   = sid s+  , _stag  = stag s+  , _sinfo = sinfo s+  }+  where+    (b, sr) = lookupBindEnv (cbind s) env+ --------------------------------------------------------------------------- -- | Top level Solvers ---------------------------------------------------- --------------------------------------------------------------------------- type Solver a = Config -> FInfo a -> IO (Result (Integer, a))  ---------------------------------------------------------------------------------saveQuery :: Config -> FInfo a -> IO ()+saveQuery :: Fixpoint a => Config -> FInfo a -> IO () -------------------------------------------------------------------------------- saveQuery cfg fi = {- when (save cfg) $ -} do   let fi'  = void fi   saveBinaryQuery cfg fi'-  saveTextQuery cfg   fi'+  saveTextQuery cfg   fi  saveBinaryQuery :: Config -> FInfo () -> IO () saveBinaryQuery cfg fi = do   let bfq  = queryFile Files.BinFq cfg   putStrLn $ "Saving Binary Query: " ++ bfq ++ "\n"   ensurePath bfq-  B.encodeFile bfq fi+  B.writeFile bfq (S.encode fi)+  -- B.encodeFile bfq fi -saveTextQuery :: Config -> FInfo () -> IO ()+saveTextQuery :: Fixpoint a => Config -> FInfo a -> IO () saveTextQuery cfg fi = do   let fq   = queryFile Files.Fq cfg   putStrLn $ "Saving Text Query: "   ++ fq ++ "\n"@@ -867,12 +911,12 @@   , aenvAutoRW   :: M.HashMap SubcId [AutoRewrite]   } deriving (Eq, Show, Generic) -instance B.Binary AutoRewrite-instance B.Binary AxiomEnv-instance B.Binary Rewrite-instance B.Binary Equation-instance B.Binary SMTSolver-instance B.Binary Eliminate+instance S.Store AutoRewrite+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@@ -880,6 +924,9 @@ instance NFData SMTSolver instance NFData Eliminate +dedupAutoRewrites :: M.HashMap SubcId [AutoRewrite] -> [AutoRewrite]+dedupAutoRewrites = Set.toList . Set.unions . map Set.fromList . M.elems+ instance Semigroup AxiomEnv where   a1 <> a2        = AEnv aenvEqs' aenvSimpl' aenvExpand' aenvAutoRW'     where@@ -902,7 +949,7 @@   , eqSort :: !Sort             -- ^ sort of body   , eqRec  :: !Bool             -- ^ is this a recursive definition   }-  deriving (Eq, Show, Generic)+  deriving (Data, Eq, Ord, Show, Generic)  mkEquation :: Symbol -> [(Symbol, Sort)] -> Expr -> Sort -> Equation mkEquation f xts e out = Equ f xts e out (f `elem` syms e)@@ -927,7 +974,7 @@   { arArgs :: [SortedReft]   , arLHS  :: Expr   , arRHS  :: Expr-} deriving (Eq, Show, Generic)+} deriving (Eq, Ord, Show, Generic)  instance Hashable SortedReft instance Hashable AutoRewrite@@ -935,11 +982,11 @@  instance Fixpoint (M.HashMap SubcId [AutoRewrite]) where   toFix autoRW =-    vcat (map fixRW rewrites)-    $+$ text "rewrite "-    <+> toFix rwsMapping+    vcat $+    map fixRW rewrites +++    rwsMapping     where-      rewrites     = L.nub $ concatMap snd (M.toList autoRW)+      rewrites = dedupAutoRewrites autoRW        fixRW rw@(AutoRewrite args lhs rhs) =           text ("autorewrite " ++ show (hash rw))@@ -953,7 +1000,7 @@       rwsMapping = do         (cid, rws) <- M.toList autoRW         rw         <-  rws-        return $ text $ show cid ++ " : " ++ show (hash rw)+        return $ "rewrite" <+> brackets (text $ show cid ++ " : " ++ show (hash rw))   @@ -965,26 +1012,28 @@   , smArgs  :: [Symbol]       -- eg. xs   , smBody  :: Expr           -- eg. e[xs]   }-  deriving (Eq, Show, Generic)+  deriving (Data, Eq, Ord, Show, Generic)  instance Fixpoint AxiomEnv where-  toFix axe = vcat ((toFix <$> aenvEqs axe) ++ (toFix <$> aenvSimpl axe))-              $+$ text "expand" <+> toFix (pairdoc <$> M.toList(aenvExpand axe))+  toFix axe = vcat ((toFix <$> L.sort (aenvEqs axe)) ++ (toFix <$> L.sort (aenvSimpl axe)))+              $+$ renderExpand (pairdoc <$> L.sort (M.toList $ aenvExpand axe))               $+$ toFix (aenvAutoRW axe)     where       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 _ _) = "define" <+> toFix f <+> ppArgs xs <+> text "=" <+> parens (toFix e)+  toFix (Equ f xs e s _) = "define" <+> toFix f <+> ppArgs xs <+> ":" <+> toFix s <+> text "=" <+> braces (parens (toFix e))  instance Fixpoint Rewrite where   toFix (SMeasure f d xs e)     = text "match"    <+> toFix f-   <+> parens (toFix d <+> hsep (toFix <$> xs))+   <+> toFix d <+> hsep (toFix <$> xs)    <+> text " = "    <+> parens (toFix e)
src/Language/Fixpoint/Types/Environments.hs view
@@ -35,6 +35,7 @@   , fromListIBindEnv   , memberIBindEnv   , unionIBindEnv+  , unionsIBindEnv   , diffIBindEnv   , intersectionIBindEnv   , nullIBindEnv@@ -43,9 +44,10 @@   -- * Global Binder Environments   , BindEnv, beBinds   , emptyBindEnv+  , fromListBindEnv   , insertBindEnv, lookupBindEnv   , filterBindEnv, mapBindEnv, mapWithKeyMBindEnv, adjustBindEnv-  , bindEnvFromList, bindEnvToList, elemsBindEnv+  , bindEnvFromList, bindEnvToList, deleteBindEnv, elemsBindEnv   , EBindEnv, splitByQuantifiers    -- * Information needed to lookup and update Solutions@@ -57,8 +59,8 @@   , makePack   ) where --- import qualified Data.Binary as B-import qualified Data.Binary as B+-- import qualified Data.Store as S+import qualified Data.Store as S import qualified Data.List   as L import           Data.Generics             (Data) #if !MIN_VERSION_base(4,14,0)@@ -67,7 +69,6 @@  import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic)-import           Data.Hashable import qualified Data.HashMap.Strict       as M import qualified Data.HashSet              as S import           Data.Maybe@@ -84,7 +85,7 @@ type BindId        = Int type BindMap a     = M.HashMap BindId a -newtype IBindEnv   = FB (S.HashSet BindId) deriving (Eq, Data, Typeable, Generic)+newtype IBindEnv   = FB (S.HashSet BindId) deriving (Eq, Data, Show, Typeable, Generic)  instance PPrint IBindEnv where   pprintTidy _ = pprint . L.sort . elemsIBindEnv@@ -114,6 +115,7 @@ instance PPrint a => PPrint (SEnv a) where   pprintTidy k = pprintKVs k . L.sortBy (compare `on` fst) . toListSEnv +{-# SCC toListSEnv #-} toListSEnv              ::  SEnv a -> [(Symbol, a)] toListSEnv (SE env)     = M.toList env @@ -138,6 +140,7 @@ insertSEnv :: Symbol -> a -> SEnv a -> SEnv a insertSEnv x v (SE env) = SE (M.insert x v env) +{-# SCC lookupSEnv #-} lookupSEnv :: Symbol -> SEnv a -> Maybe a lookupSEnv x (SE env)   = M.lookup x env @@ -162,6 +165,7 @@ unionSEnv' :: SEnv a -> SEnv a -> SEnv a unionSEnv' (SE m1) (SE m2)    = SE (M.union m1 m2) +{-# SCC lookupSEnvWithDistance #-} lookupSEnvWithDistance :: Symbol -> SEnv a -> SESearch a lookupSEnvWithDistance x (SE env)   = case M.lookup x env of@@ -208,6 +212,9 @@ insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv) insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m)) +fromListBindEnv :: [(BindId, (Symbol, SortedReft))] -> BindEnv+fromListBindEnv xs = BE (length xs) (M.fromList xs)+ emptyBindEnv :: BindEnv emptyBindEnv = BE 0 M.empty @@ -247,6 +254,9 @@ unionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv unionIBindEnv (FB m1) (FB m2) = FB $ m1 `S.union` m2 +unionsIBindEnv :: [IBindEnv] -> IBindEnv+unionsIBindEnv = L.foldl' unionIBindEnv emptyIBindEnv+ intersectionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv intersectionIBindEnv (FB m1) (FB m2) = FB $ m1 `S.intersection` m2 @@ -259,6 +269,9 @@ adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv adjustBindEnv f i (BE n m) = BE n $ M.adjust f i m +deleteBindEnv :: BindId -> BindEnv -> BindEnv+deleteBindEnv i (BE n m) = BE n $ M.delete i m+ instance Functor SEnv where   fmap = mapSEnv @@ -306,13 +319,13 @@ instance NFData BindEnv instance (NFData a) => NFData (SEnv a) -instance B.Binary Packs-instance B.Binary IBindEnv-instance B.Binary BindEnv-instance (B.Binary a) => B.Binary (SEnv a)-instance (Hashable a, Eq a, B.Binary a) => B.Binary (S.HashSet a) where-  put = B.put . S.toList-  get = S.fromList <$> B.get+instance S.Store Packs+instance S.Store IBindEnv+instance S.Store BindEnv+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+--   get = S.fromList <$> B.get  -------------------------------------------------------------------------------- -- | Constraint Pack Sets ------------------------------------------------------
src/Language/Fixpoint/Types/Errors.hs view
@@ -23,7 +23,7 @@   , FixResult (..)   , colorResult   , resultDoc-  , resultExit +  , resultExit    -- * Error Type   , Error, Error1@@ -50,11 +50,13 @@   , errFreeVarInQual   , errFreeVarInConstraint   , errIllScopedKVar+  , errBadDataDecl   ) where  import           System.Exit                        (ExitCode (..)) import           Control.Exception import           Data.Serialize                (Serialize (..))+import           Data.Aeson                    hiding (Error, Result) import           Data.Generics                 (Data) import           Data.Typeable #if !MIN_VERSION_base(4,14,0)@@ -63,7 +65,7 @@  import           Control.DeepSeq -- import           Data.Hashable-import qualified Data.Binary                   as B+import qualified Data.Store                   as S import           GHC.Generics                  (Generic) import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Spans@@ -89,7 +91,7 @@ instance Serialize Error instance Serialize (FixResult Error) -instance (B.Binary a) => B.Binary (FixResult a)+instance (S.Store a) => S.Store (FixResult a)  -------------------------------------------------------------------------------- -- | A BareBones Error Type ----------------------------------------------------@@ -203,16 +205,34 @@   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 (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) +instance (Fixpoint a) => PPrint (FixResult a) where+  pprintTidy _ = resultDoc+ colorResult :: FixResult a -> Moods colorResult (Safe (Solver.totalWork -> 0)) = Wary colorResult (Safe _)                       = Happy colorResult (Unsafe _ _)                   = Angry-colorResult (_)                            = Sad+colorResult _                              = Sad  resultExit :: FixResult a -> ExitCode resultExit (Safe _stats) = ExitSuccess@@ -221,6 +241,9 @@ --------------------------------------------------------------------- -- | Catalogue of Errors -------------------------------------------- ---------------------------------------------------------------------++errBadDataDecl :: (Loc x, PPrint x) => x -> Error+errBadDataDecl d = err (srcSpan d) $ "Non-regular datatype declaration" <+> pprint d  errFreeVarInQual :: (PPrint q, Loc q, PPrint x) => q -> x -> Error errFreeVarInQual q x = err sp $ vcat [ "Qualifier with free vars"
src/Language/Fixpoint/Types/Names.hs view
@@ -45,11 +45,14 @@   , isDummy    -- * Destructors+  , prefixOfSym+  , suffixOfSym   , stripPrefix   , stripSuffix    , consSym   , unconsSym   , dropSym+  , dropPrefixOfSym   , headSym   , lengthSym @@ -69,9 +72,11 @@   , intSymbol   , tempSymbol   , gradIntSymbol+  , appendSymbolText    -- * Wrapping Symbols   , litSymbol+  , bindSymbol   , testSymbol   , renameSymbol   , kArgSymbol@@ -110,7 +115,7 @@   , divFuncName    -- * Casting function names-  , setToIntName, bitVecToIntName, mapToIntName, boolToIntName, realToIntName, toIntName+  , setToIntName, bitVecToIntName, mapToIntName, boolToIntName, realToIntName, toIntName, tyCastName   , setApplyName, bitVecApplyName, mapApplyName, boolApplyName, realApplyName, intApplyName   , applyName   , coerceName@@ -130,18 +135,21 @@ #endif import           Data.Generics               (Data) import           Data.Hashable               (Hashable (..))-import qualified Data.HashSet                as S+import qualified Data.HashSet                as S hiding (size) import           Data.Interned import           Data.Interned.Internal.Text import           Data.String                 (IsString(..)) import qualified Data.Text                   as T-import qualified Data.Text.Lazy.Builder      as Builder-import           Data.Binary                 (Binary (..))+import qualified Data.Store                  as S import           Data.Typeable               (Typeable)+import qualified GHC.Arr                     as Arr import           GHC.Generics                (Generic) import           Text.PrettyPrint.HughesPJ   (text) import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Spans+import           Language.Fixpoint.Utils.Builder as Builder (Builder, fromText)+import Data.Functor.Contravariant (Contravariant(contramap))+import qualified Data.Binary as B  --------------------------------------------------------------- -- | Symbols --------------------------------------------------@@ -166,8 +174,8 @@  data Symbol   = S { _symbolId      :: !Id-      , symbolRaw     :: !T.Text-      , symbolEncoded :: !T.Text+      , symbolRaw      :: T.Text+      , symbolEncoded  :: T.Text       } deriving (Data, Typeable, Generic)  instance Eq Symbol where@@ -189,19 +197,24 @@   unintern (S _ t _) = t  instance Hashable (Description Symbol) where-  hashWithSalt s (DT t) = hashWithSalt s t+  hashWithSalt s (DT t) = {-# SCC "hashWithSalt-Description-Symbol" #-} hashWithSalt s t  instance Hashable Symbol where   -- NOTE: hash based on original text rather than id   hashWithSalt s (S _ t _) = hashWithSalt s t  instance NFData Symbol where-  rnf (S {}) = ()+  rnf S {} = () -instance Binary Symbol where-  get = textSymbol <$> get-  put = put . symbolText+instance S.Store Symbol where+  poke = S.poke . symbolText+  peek = textSymbol <$> S.peek+  size = contramap symbolText S.size +instance B.Binary Symbol where+   get = textSymbol <$> B.get+   put = B.put . symbolText+ sCache :: Cache Symbol sCache = mkCache {-# NOINLINE sCache #-}@@ -262,6 +275,7 @@ symbolText :: Symbol -> T.Text symbolText = symbolRaw +{-# SCC symbolString #-} symbolString :: Symbol -> String symbolString = T.unpack . symbolText @@ -277,6 +291,7 @@  -- INVARIANT: All strings *must* be built from here +{-# SCC textSymbol #-} textSymbol :: T.Text -> Symbol textSymbol = intern @@ -288,8 +303,18 @@ isFixKey :: T.Text -> Bool isFixKey x = S.member x keywords +{-# SCC encodeUnsafe #-} encodeUnsafe :: T.Text -> T.Text-encodeUnsafe = joinChunks . splitChunks . prefixAlpha+encodeUnsafe t = T.pack $ pad $ go $ T.unpack (prefixAlpha t)+  where+    pad cs@('$':_) = 'z' : '$' : cs+    pad cs = cs+    go [] = []+    go (c:cs) =+      if isUnsafeChar c then+        '$' : shows (ord c) ('$' : go cs)+      else+        c : go cs  prefixAlpha :: T.Text -> T.Text prefixAlpha t@@ -301,30 +326,13 @@                Just (c, _) -> S.member c alphaChars                Nothing     -> False -joinChunks :: (T.Text, [(Char, SafeText)]) -> SafeText-joinChunks (t, [] ) = t-joinChunks (t, cts) = T.concat $ padNull t : (tx <$> cts)-  where-    tx (c, ct)      = mconcat ["$", c2t c, "$", ct]-    c2t             = T.pack . show . ord--padNull :: T.Text -> T.Text-padNull t-  | T.null t  = "z$"-  | otherwise = t--splitChunks :: T.Text -> (T.Text, [(Char, SafeText)])-splitChunks t = (h, go tl)-  where-    (h, tl)   = T.break isUnsafeChar t-    go !ut    = case T.uncons ut of-                  Nothing       -> []-                  Just (c, ut') -> let (ct, utl) = T.break isUnsafeChar ut'-                                   in (c, ct) : go utl- isUnsafeChar :: Char -> Bool-isUnsafeChar = not . (`S.member` okSymChars)-+isUnsafeChar c =+  let ic = ord c+   in if ic < Arr.numElements okSymChars then+        not (okSymChars Arr.! ic)+      else+        True  keywords :: S.HashSet T.Text keywords   = S.fromList [ "env"@@ -362,8 +370,12 @@ symChars =  safeChars `mappend`             S.fromList ['%', '#', '$', '\''] -okSymChars :: S.HashSet Char-okSymChars = safeChars+okSymChars :: Arr.Array Int Bool+okSymChars =+    Arr.listArray (0, maxChar) [ S.member (toEnum i) safeChars | i <- [0..maxChar]]+  where+    cs = S.toList safeChars+    maxChar = ord (maximum cs)  isPrefixOfSym :: Symbol -> Symbol -> Bool isPrefixOfSym (symbolText -> p) (symbolText -> x) = p `T.isPrefixOf` x@@ -390,6 +402,16 @@ dropSym :: Int -> Symbol -> Symbol dropSym n (symbolText -> t) = symbol $ T.drop n t +dropPrefixOfSym :: Symbol -> Symbol+dropPrefixOfSym =+  symbol .  T.drop (T.length symSepName) .  snd .  T.breakOn symSepName .  symbolText++prefixOfSym :: Symbol -> Symbol+prefixOfSym = symbol . fst . T.breakOn symSepName . symbolText++suffixOfSym :: Symbol -> Symbol+suffixOfSym = symbol . snd . T.breakOnEnd symSepName . symbolText+ stripPrefix :: Symbol -> Symbol -> Maybe Symbol stripPrefix p x = symbol <$> T.stripPrefix (symbolText p) (symbolText x) @@ -401,8 +423,11 @@ -- | Use this **EXCLUSIVELY** when you want to add stuff in front of a Symbol -------------------------------------------------------------------------------- suffixSymbol :: Symbol -> Symbol -> Symbol-suffixSymbol  x y = x `mappendSym` symSepName `mappendSym` y+suffixSymbol  x y = symbol $ suffixSymbolText (symbolText x) (symbolText y) +suffixSymbolText :: T.Text -> T.Text -> T.Text+suffixSymbolText  x y = x <> symSepName <> y+ vv                  :: Maybe Integer -> Symbol -- vv (Just i)         = symbol $ symbolSafeText vvName `T.snoc` symSepName `mappend` T.pack (show i) vv (Just i)         = intSymbol vvName i@@ -438,8 +463,11 @@ unLitSymbol = stripPrefix litPrefix  intSymbol :: (Show a) => Symbol -> a -> Symbol-intSymbol x i = x `suffixSymbol` symbol (show i)+intSymbol x i = symbol $ symbolText x `suffixSymbolText` T.pack (show i) +appendSymbolText :: Symbol -> T.Text -> T.Text+appendSymbolText s t = encode (symbolText s <> symSepName <> t)+ tempSymbol :: Symbol -> Integer -> Symbol tempSymbol prefix = intSymbol (tempPrefix `mappendSym` prefix) @@ -455,12 +483,19 @@ gradIntSymbol :: Integer -> Symbol gradIntSymbol = intSymbol gradPrefix -tempPrefix, anfPrefix, renamePrefix, litPrefix, gradPrefix :: Symbol+-- | Used to define functions corresponding to binding predicates+--+-- The integer is the BindId.+bindSymbol :: Integer -> Symbol+bindSymbol = intSymbol bindPrefix++tempPrefix, anfPrefix, renamePrefix, litPrefix, gradPrefix, bindPrefix :: Symbol tempPrefix   = "lq_tmp$" anfPrefix    = "lq_anf$" renamePrefix = "lq_rnm$" litPrefix    = "lit$" gradPrefix   = "grad$"+bindPrefix   = "b$"  testPrefix  :: Symbol testPrefix   = "is$"@@ -513,7 +548,7 @@ instance Symbolic Symbol where   symbol = id -symbolBuilder :: (Symbolic a) => a -> Builder.Builder+symbolBuilder :: (Symbolic a) => a -> Builder symbolBuilder = Builder.fromText . symbolSafeText . symbol  {-# INLINE buildMany #-}@@ -538,12 +573,13 @@ isLamArgSymbol :: Symbol -> Bool isLamArgSymbol = isPrefixOfSym lamArgPrefix -setToIntName, bitVecToIntName, mapToIntName, realToIntName, toIntName :: Symbol+setToIntName, bitVecToIntName, mapToIntName, realToIntName, toIntName, tyCastName :: Symbol setToIntName    = "set_to_int" bitVecToIntName = "bitvec_to_int" mapToIntName    = "map_to_int" realToIntName   = "real_to_int" toIntName       = "cast_as_int"+tyCastName      = "cast_as"  boolToIntName :: (IsString a) => a boolToIntName   = "bool_to_int"
src/Language/Fixpoint/Types/PrettyPrint.hs view
@@ -110,11 +110,11 @@ instance PPrint a => PPrint [a] where   pprintTidy k = brackets . sep . punctuate comma . map (pprintTidy k) -instance PPrint a => PPrint (S.HashSet a) where-  pprintTidy k = pprintTidy k . S.toList+instance (Ord a, PPrint a) => PPrint (S.HashSet a) where+  pprintTidy k = pprintTidy k . L.sort . S.toList -instance (PPrint a, PPrint b) => PPrint (M.HashMap a b) where-  pprintTidy k = pprintKVs k . M.toList+instance (Ord a, PPrint a, PPrint b) => PPrint (M.HashMap a b) where+  pprintTidy k = pprintKVs k . hashMapToAscList  pprintKVs   :: (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc pprintKVs t = vcat . punctuate "\n" . map pp1
src/Language/Fixpoint/Types/Refinements.hs view
@@ -6,8 +6,10 @@ {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE GADTs                      #-}@@ -37,7 +39,7 @@   -- * Constructing Terms   , eVar, elit   , eProp-  , pAnd, pOr, pIte+  , conj, pAnd, pOr, pIte, pAndNoDedup   , (&.&), (|.|)   , pExist   , mkEApp@@ -79,12 +81,17 @@   , conjuncts   , eApps   , eAppC+  , exprKVars+  , exprSymbolsSet   , splitEApp   , splitPAnd   , reftConjuncts+  , sortedReftSymbols+  , substSortInExpr    -- * Transforming   , mapPredReft+  , onEverySubexpr   , pprintReft    , debruijnIndex@@ -97,12 +104,18 @@   ) where  import           Prelude hiding ((<>))-import qualified Data.Binary as B-import           Data.Generics             (Data)+import           Data.Bifunctor (second)+import qualified Data.Store as S+import           Data.Generics             (Data, gmapT, mkT, extT) import           Data.Typeable             (Typeable) import           Data.Hashable+import           Data.HashMap.Strict         (HashMap)+import qualified Data.HashMap.Strict       as HashMap+import           Data.HashSet              (HashSet)+import qualified Data.HashSet              as HashSet import           GHC.Generics              (Generic) import           Data.List                 (foldl', partition)+import qualified Data.Set                  as Set import           Data.String import           Data.Text                 (Text) import qualified Data.Text                 as T@@ -115,6 +128,7 @@ import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Misc import           Text.PrettyPrint.HughesPJ.Compat+import qualified Data.Binary as B  -- import           Text.Printf               (printf) @@ -131,29 +145,52 @@ instance NFData Reft instance NFData SortedReft -instance (Hashable k, Eq k, B.Binary k, B.Binary v) => B.Binary (M.HashMap k v) where-  put = B.put . M.toList-  get = M.fromList <$> B.get+-- instance (Hashable k, Eq k, S.Store k, S.Store v) => S.Store (M.HashMap k v) where+  -- put = B.put . M.toList+  -- get = M.fromList <$> B.get -instance (Eq a, Hashable a, B.Binary a) => B.Binary (TCEmb a) +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+instance S.Store Constant+instance S.Store SymConst+instance S.Store Brel+instance S.Store Bop+instance S.Store Expr+instance S.Store Reft+instance S.Store SortedReft++instance B.Binary SymConst+instance B.Binary Constant+instance B.Binary Bop instance B.Binary SrcSpan-instance B.Binary KVar-instance B.Binary Subst instance B.Binary GradInfo-instance B.Binary Constant-instance B.Binary SymConst instance B.Binary Brel-instance B.Binary Bop+instance B.Binary KVar+instance (Hashable a, Eq a, B.Binary a) => B.Binary (HashSet a) where+  put = B.put . HashSet.toList+  get = HashSet.fromList <$> B.get+instance (Hashable k, Eq k, B.Binary k, B.Binary v) => B.Binary (M.HashMap k v) where+  put = B.put . M.toList+  get = M.fromList <$> B.get++instance B.Binary Subst  instance B.Binary Expr-instance B.Binary Reft-instance B.Binary SortedReft+instance B.Binary Reft +instance B.Binary TCArgs+instance (Eq a, Hashable a, B.Binary a) => B.Binary (TCEmb a) + reftConjuncts :: Reft -> [Reft] reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- ras']   where-    ras'                     = if null ps then ks else ((pAnd ps) : ks)+    ras'                     = if null ps then ks else ((conj ps) : ks)  -- see [NOTE:pAnd-SLOW]     (ks, ps)                 = partition (\p -> isKvar p || isGradual p) $ refaConjuncts ra ++ isKvar :: Expr -> Bool isKvar (PKVar _ _) = True isKvar _           = False@@ -219,7 +256,7 @@ -- | Substitutions ------------------------------------------------------------- -------------------------------------------------------------------------------- newtype Subst = Su (M.HashMap Symbol Expr)-                deriving (Eq, Data, Typeable, Generic)+                deriving (Eq, Data, Ord, Typeable, Generic)  instance Show Subst where   show = showFix@@ -285,23 +322,108 @@           | PExist ![(Symbol, Sort)] !Expr           | PGrad  !KVar !Subst !GradInfo !Expr           | ECoerc !Sort !Sort !Expr  -          deriving (Eq, Show, Data, Typeable, Generic)+          deriving (Eq, Show, Ord, Data, Typeable, Generic) +onEverySubexpr :: (Expr -> Expr) -> Expr -> Expr+onEverySubexpr = everywhereOnA++-- | Like 'Data.Generics.everywhere' but only traverses the nodes+-- of type @a@ or @[a]@.+everywhereOnA :: forall a. Data a => (a -> a) -> a -> a+everywhereOnA f = go+  where+    go :: a -> a+    go = f . gmapT (mkT go `extT` map go)+ type Pred = Expr -pattern PTrue         = PAnd []-pattern PTop          = PAnd []-pattern PFalse        = POr  []-pattern EBot          = POr  []-pattern EEq e1 e2     = PAtom Eq    e1 e2-pattern ETimes e1 e2  = EBin Times  e1 e2+pattern PTrue :: Expr+pattern PTrue = PAnd []++pattern PTop :: Expr+pattern PTop = PAnd []++pattern PFalse :: Expr+pattern PFalse = POr  []++pattern EBot :: Expr+pattern EBot = POr  []++pattern EEq :: Expr -> Expr -> Expr+pattern EEq e1 e2 = PAtom Eq    e1 e2++pattern ETimes :: Expr -> Expr -> Expr+pattern ETimes e1 e2 = EBin Times  e1 e2++pattern ERTimes :: Expr -> Expr -> Expr pattern ERTimes e1 e2 = EBin RTimes e1 e2-pattern EDiv e1 e2    = EBin Div    e1 e2-pattern ERDiv e1 e2   = EBin RDiv   e1 e2 +pattern EDiv :: Expr -> Expr -> Expr+pattern EDiv e1 e2 = EBin Div    e1 e2 +pattern ERDiv :: Expr -> Expr -> Expr+pattern ERDiv e1 e2 = EBin RDiv   e1 e2++exprSymbolsSet :: Expr -> HashSet Symbol+exprSymbolsSet = go+  where+    gos es                = HashSet.unions (go <$> es)+    go (EVar x)           = HashSet.singleton x+    go (EApp f e)         = gos [f, e]+    go (ELam (x,_) e)     = HashSet.delete x (go e)+    go (ECoerc _ _ e)     = go e+    go (ENeg e)           = go e+    go (EBin _ e1 e2)     = gos [e1, e2]+    go (EIte p e1 e2)     = gos [p, e1, e2]+    go (ECst e _)         = go e+    go (PAnd ps)          = gos ps+    go (POr ps)           = gos ps+    go (PNot p)           = go p+    go (PIff p1 p2)       = gos [p1, p2]+    go (PImp p1 p2)       = gos [p1, p2]+    go (PAtom _ e1 e2)    = gos [e1, e2]+    go (PKVar _ (Su su))  = HashSet.unions $ map exprSymbolsSet (M.elems su)+    go (PAll xts p)       = go p `HashSet.difference` HashSet.fromList (fst <$> xts)+    go (PExist xts p)     = go p `HashSet.difference` HashSet.fromList (fst <$> xts)+    go _                  = HashSet.empty++substSortInExpr :: (Symbol -> Sort) -> Expr -> Expr+substSortInExpr f = onEverySubexpr go+  where+    go = \case+      ELam (x, t) e -> ELam (x, substSort f t) e+      PAll xts e -> PAll (second (substSort f) <$> xts) e+      PExist xts e -> PExist (second (substSort f) <$> xts) e+      ECst e t -> ECst e (substSort f t)+      ECoerc t0 t1 e -> ECoerc (substSort f t0) (substSort f t1) e+      e -> e++exprKVars :: Expr -> HashMap KVar [Subst]+exprKVars = go+  where+    gos es                = HashMap.unions (go <$> es)+    go (EVar _)           = HashMap.empty+    go (EApp f e)         = gos [f, e]+    go (ELam _ e)     = go e+    go (ECoerc _ _ e)     = go e+    go (ENeg e)           = go e+    go (EBin _ e1 e2)     = gos [e1, e2]+    go (EIte p e1 e2)     = gos [p, e1, e2]+    go (ECst e _)         = go e+    go (PAnd ps)          = gos ps+    go (POr ps)           = gos ps+    go (PNot p)           = go p+    go (PIff p1 p2)       = gos [p1, p2]+    go (PImp p1 p2)       = gos [p1, p2]+    go (PAtom _ e1 e2)    = gos [e1, e2]+    go (PKVar k substs@(Su su))  =+      HashMap.insertWith (++) k [substs] $ HashMap.unions $ map exprKVars (M.elems su)+    go (PAll _xts p)       = go p+    go (PExist _xts p)     = go p+    go _                  = HashMap.empty+ data GradInfo = GradInfo {gsrc :: SrcSpan, gused :: Maybe SrcSpan}-          deriving (Eq, Show, Data, Typeable, Generic)+          deriving (Eq, Ord, Show, Data, Typeable, Generic)  srcGradInfo :: SourcePos -> GradInfo srcGradInfo src = GradInfo (SS src src) Nothing@@ -355,11 +477,17 @@ -- | Parsed refinement of @Symbol@ as @Expr@ --   e.g. in '{v: _ | e }' v is the @Symbol@ and e the @Expr@ newtype Reft = Reft (Symbol, Expr)-               deriving (Eq, Data, Typeable, Generic)+               deriving (Eq, Ord, Data, Typeable, Generic)  data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft }-                  deriving (Eq, Data, Typeable, Generic)+                  deriving (Eq, Ord, Data, Typeable, Generic) +sortedReftSymbols :: SortedReft -> HashSet Symbol+sortedReftSymbols sr =+  HashSet.union+    (sortSymbols $ sr_sort sr)+    (exprSymbolsSet $ reftPred $ sr_reft sr)+ elit :: Located Symbol -> Sort -> Expr elit l s = ECon $ L (symbolText $ val l) s @@ -385,7 +513,7 @@ -- _decodeSymConst = fmap (SL . symbolText) . unLitSymbol  instance Fixpoint SymConst where-  toFix  = toFix . encodeSymConst+  toFix (SL t) = text (show t)  instance Fixpoint KVar where   toFix (KV k) = text "$" <-> toFix k@@ -410,13 +538,13 @@   toFix Mod    = text "mod"  instance Fixpoint Expr where-  toFix (ESym c)       = toFix $ encodeSymConst c+  toFix (ESym c)       = toFix c   toFix (ECon c)       = toFix c   toFix (EVar s)       = toFix s   toFix e@(EApp _ _)   = parens $ hcat $ punctuate " " $ toFix <$> (f:es) where (f, es) = splitEApp e   toFix (ENeg e)       = parens $ text "-"  <+> parens (toFix e)-  toFix (EBin o e1 e2) = parens $ toFix e1  <+> toFix o <+> toFix e2-  toFix (EIte p e1 e2) = parens $ text "if" <+> toFix p <+> text "then" <+> toFix e1 <+> text "else" <+> toFix e2+  toFix (EBin o e1 e2) = parens $ sep [toFix e1  <+> toFix o, nest 2 (toFix e2)]+  toFix (EIte p e1 e2) = parens $ sep [text "if" <+> toFix p <+> text "then", nest 2 (toFix e1), text "else", nest 2 (toFix e2)]   -- toFix (ECst e _so)   = toFix e   toFix (ECst e so)    = parens $ toFix e   <+> text " : " <+> toFix so   -- toFix (EBot)         = text "_|_"@@ -428,7 +556,7 @@   toFix (PIff p1 p2)   = parens $ toFix p1 <+> text "<=>" <+> toFix p2   toFix (PAnd ps)      = text "&&" <+> toFix ps   toFix (POr  ps)      = text "||" <+> toFix ps-  toFix (PAtom r e1 e2)  = parens $ toFix e1 <+> toFix r <+> toFix e2+  toFix (PAtom r e1 e2)  = parens $ sep [ toFix e1 <+> toFix r, nest 2 (toFix e2)]   toFix (PKVar k su)     = toFix k <-> toFix su   toFix (PAll xts p)     = "forall" <+> (toFix xts                                         $+$ ("." <+> toFix p))@@ -440,28 +568,59 @@   toFix (ECoerc a t e)   = parens (text "coerce" <+> toFix a <+> text "~" <+> toFix t <+> text "in" <+> toFix e)   toFix (ELam (x,s) e)   = text "lam" <+> toFix x <+> ":" <+> toFix s <+> "." <+> toFix e -  simplify (PAnd [])     = PTrue-  simplify (POr  [])     = PFalse-  simplify (PAnd [p])    = simplify p-  simplify (POr  [p])    = simplify p+  simplify = simplifyExpr dedup+    where+      dedup = Set.toList . Set.fromList -  simplify (PGrad k su i e)-    | isContraPred e      = PFalse-    | otherwise           = PGrad k su i (simplify e)+simplifyExpr :: ([Expr] -> [Expr]) -> Expr -> Expr+simplifyExpr dedup = go+  where+    go (POr  [])     = PFalse+    go (POr  [p])    = go p+    go (PNot p) =+      let sp = go p+       in case sp of+            PNot e -> e+            _ -> PNot sp+    -- XXX: Do not simplify PImp until PLE can handle it+    -- https://github.com/ucsd-progsys/liquid-fixpoint/issues/475+    -- go (PImp p q) =+    --   let sq = go q+    --    in if sq == PTrue then PTrue+    --       else if sq == PFalse then go (PNot p)+    --       else PImp (go p) sq+    go (PIff p q)    =+      let sp = go p+          sq = go q+       in if sp == sq then PTrue+          else if sp == PTrue then sq+          else if sq == PTrue then sp+          else if sp == PFalse then PNot sq+          else if sq == PFalse then PNot sp+          else PIff sp sq -  simplify (PAnd ps)-    | any isContraPred ps = PFalse-    | otherwise           = PAnd $ filter (not . isTautoPred) $ map simplify ps+    go (PGrad k su i e)+      | isContraPred e      = PFalse+      | otherwise           = PGrad k su i (go e) -  simplify (POr  ps)-    | any isTautoPred ps = PTrue-    | otherwise          = POr  $ filter (not . isContraPred) $ map simplify ps+    go (PAnd ps)+      | any isContraPred ps = PFalse+                           -- Note: Performance of some tests is very sensitive to this code. See #480+      | otherwise           = simplPAnd . dedup . flattenRefas . filter (not . isTautoPred) $ map go ps+      where+        simplPAnd [] = PTrue+        simplPAnd [p] = p+        simplPAnd xs = PAnd xs -  simplify p-    | isContraPred p     = PFalse-    | isTautoPred  p     = PTrue-    | otherwise          = p+    go (POr  ps)+      | any isTautoPred ps = PTrue+      | otherwise          = POr  $ filter (not . isContraPred) $ map go ps +    go p+      | isContraPred p     = PFalse+      | isTautoPred  p     = PTrue+      | otherwise          = p+ isContraPred   :: Expr -> Bool isContraPred z = eqC z || (z `elem` contras)   where@@ -578,8 +737,8 @@     where zi = 1    -- RJ: DO NOT DELETE!-  --  pprintPrec _ k (ECst e so)     = parens $ pprint e <+> ":" <+> {- const (text "...") -} (pprintTidy k so)-  pprintPrec z k (ECst e _)      = pprintPrec z k e+  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   pprintPrec z k (PNot p)        = parensIf (z > zn) $@@ -708,8 +867,22 @@   | e2 == EVar v           = Just e1 isSingletonExpr _ _        = Nothing +-- | 'conj' is a fast version of 'pAnd' needed for the ebind tests+conj :: [Pred] -> Pred+conj []  = PFalse+conj [p] = p+conj ps  = PAnd ps++-- | [NOTE: pAnd-SLOW] 'pAnd' and 'pOr' are super slow as they go inside the predicates;+--   so they SHOULD NOT be used inside the solver loop. Instead, use 'conj' which ensures+--   some basic things but is faster.+ pAnd, pOr     :: ListNE Pred -> Pred pAnd          = simplify . PAnd++pAndNoDedup :: ListNE Pred -> Pred+pAndNoDedup = simplifyExpr id . PAnd+ pOr           = simplify . POr  (&.&) :: Pred -> Pred -> Pred@@ -803,10 +976,11 @@ falseReft = Reft (vv_, PFalse)  flattenRefas :: [Expr] -> [Expr]-flattenRefas        = concatMap flatP+flattenRefas        = flatP []   where-    flatP (PAnd ps) = concatMap flatP ps-    flatP p         = [p]+    flatP acc (PAnd ps:xs) = flatP (flatP acc xs) ps+    flatP acc (p:xs)       = p : flatP acc xs+    flatP acc []           = acc  conjuncts :: Expr -> [Expr] conjuncts (PAnd ps) = concatMap conjuncts ps@@ -823,8 +997,8 @@   isFalse :: a -> Bool  instance Falseable Expr where-  isFalse (PFalse) = True-  isFalse _        = False+  isFalse PFalse = True+  isFalse _      = False  instance Falseable Reft where   isFalse (Reft (_, ra)) = isFalse ra
src/Language/Fixpoint/Types/Solutions.hs view
@@ -24,6 +24,7 @@     Solution, GSolution   , Sol (gMap, sEnv, sEbd, sxEnv)   , updateGMap, updateGMapWithKey+  , sHyp   , sScp   , CMap
src/Language/Fixpoint/Types/Sorts.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE UndecidableInstances       #-}@@ -57,7 +58,10 @@   , functionSort   , mkFFunc   , bkFFunc+  , bkAbs   , mkPoly+  , sortSymbols+  , substSort    , isNumeric, isReal, isString, isPolyInst @@ -78,7 +82,7 @@   , tceMap   ) where -import qualified Data.Binary as B+import qualified Data.Store as S import           Data.Generics             (Data) import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic)@@ -88,6 +92,8 @@ #endif  import           Data.Hashable+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import           Data.List                 (foldl') import           Control.DeepSeq import           Data.Maybe                (fromMaybe)@@ -98,6 +104,7 @@ import           Text.PrettyPrint.HughesPJ.Compat import qualified Data.HashMap.Strict       as M import qualified Data.List                 as L+import qualified Data.Binary as B  data FTycon   = TC LocSymbol TCInfo deriving (Ord, Show, Data, Typeable, Generic) @@ -261,6 +268,22 @@           | FApp  !Sort !Sort    -- ^ constructed type             deriving (Eq, Ord, Show, Data, Typeable, Generic) +sortSymbols :: Sort -> HashSet Symbol+sortSymbols = \case+  FObj s -> HashSet.singleton s+  FFunc t0 t1 -> HashSet.union (sortSymbols t0) (sortSymbols t1)+  FAbs _ t -> sortSymbols t+  FApp t0 t1 -> HashSet.union (sortSymbols t0) (sortSymbols t1)+  _ -> HashSet.empty++substSort :: (Symbol -> Sort) -> Sort -> Sort+substSort f = \case+  FObj s -> f s+  FFunc t0 t1 -> FFunc (substSort f t0) (substSort f t1)+  FApp t0 t1 -> FApp (substSort f t0) (substSort f t1)+  FAbs i t -> FAbs i (substSort f t)+  t -> t+ data DataField = DField   { dfName :: !LocSymbol          -- ^ Field Name   , dfSort :: !Sort               -- ^ Field Sort@@ -277,7 +300,6 @@   , ddCtors :: [DataCtor]         -- ^ Datatype Ctors. Invariant: type variables bound in ctors are greater than ddVars   } deriving (Eq, Ord, Show, Data, Typeable, Generic) - instance Loc DataDecl where     srcSpan (DDecl ty _ _) = srcSpan ty @@ -290,7 +312,7 @@ instance Symbolic DataCtor where   symbol = val . dcName -+-------------------------------------------------------------------------------------------------- muSort  :: [DataDecl] -> [DataDecl] muSort dds = mapSortDataDecl tx <$> dds   where@@ -301,10 +323,11 @@     mapSortDataCTor f  ct = ct { dcFields = mapSortDataField f <$> dcFields ct }     mapSortDataField f df = df { dfSort   = f $ dfSort df } + isFirstOrder, isFunction :: Sort -> Bool isFirstOrder (FFunc sx s) = not (isFunction sx) && isFirstOrder s isFirstOrder (FAbs _ s)   = isFirstOrder s-isFirstOrder (FApp s1 s2) = (not $ isFunction s1) && (not $ isFunction s2)+isFirstOrder (FApp s1 s2) = not (isFunction s1) && not (isFunction s2) isFirstOrder _            = True  isFunction (FAbs _ s)  = isFunction s@@ -373,8 +396,8 @@ isPolyInst s t = isPoly s && not (isPoly t)  isPoly :: Sort -> Bool-isPoly (FAbs {}) = True-isPoly _         = False+isPoly FAbs {} = True+isPoly _       = False  mkPoly :: Int -> Sort -> Sort  mkPoly i s = foldl (flip FAbs) s [0..i] @@ -494,15 +517,20 @@ sortSubst θ (FAbs i t)    = FAbs i (sortSubst θ t) sortSubst _  t            = t --- instance (B.Binary a) => B.Binary (TCEmb a) -instance B.Binary TCArgs -instance B.Binary FTycon+-- instance (S.Store a) => S.Store (TCEmb a) +instance S.Store TCArgs +instance S.Store FTycon+instance S.Store TCInfo+instance S.Store Sort+instance S.Store DataField+instance S.Store DataCtor+instance S.Store DataDecl+instance S.Store Sub++-- | We need the Binary instances for LH's spec serialization instance B.Binary TCInfo+instance B.Binary FTycon instance B.Binary Sort-instance B.Binary DataField-instance B.Binary DataCtor-instance B.Binary DataDecl-instance B.Binary Sub  instance NFData FTycon where   rnf (TC x i) = x `seq` i `seq` ()
src/Language/Fixpoint/Types/Spans.hs view
@@ -7,8 +7,16 @@ module Language.Fixpoint.Types.Spans (    -- * Concrete Location Type-    SourcePos+    SourcePos(..)+  , SourceName   , SrcSpan (..)+  , Pos+  , predPos+  , safePos+  , safeSourcePos+  , succPos+  , unPos+  , mkPos    -- * Located Values   , Loc (..)@@ -22,6 +30,7 @@   , dummyPos   , atLoc   , toSourcePos+  , ofSourcePos    -- * Destructing spans   , sourcePosElts@@ -36,13 +45,15 @@ import           Data.Hashable import           Data.Typeable import           Data.String-import qualified Data.Binary                   as B+import qualified Data.Store                   as S import           GHC.Generics                  (Generic) import           Language.Fixpoint.Types.PrettyPrint -- import           Language.Fixpoint.Misc-import           Text.Parsec.Pos+import           Text.Megaparsec.Pos import           Text.PrettyPrint.HughesPJ import           Text.Printf+import Data.Functor.Contravariant (Contravariant(contramap))+import qualified Data.Binary as B -- import           Debug.Trace  @@ -54,26 +65,78 @@   srcSpan :: a -> SrcSpan  -------------------------------------------------------------------------- | Retrofitting instances to SourcePos ------------------------------+-- Additional (orphan) instances for megaparsec's Pos type ------------ -----------------------------------------------------------------------+instance S.Store Pos where+  poke = S.poke . unPos+  peek = mkPos <$> S.peek+  size = contramap unPos S.size -instance NFData SourcePos where-  rnf = rnf . ofSourcePos+instance Serialize Pos where+  put = put . unPos+  get = mkPos <$> get -instance B.Binary SourcePos where-  put = B.put . ofSourcePos-  get = toSourcePos <$> B.get+instance Hashable Pos where+  hashWithSalt i = hashWithSalt i . unPos +instance PrintfArg Pos where+  formatArg = formatArg . unPos+  parseFormat = parseFormat . unPos++-- | Computes, safely, the predecessor of a 'Pos' value, stopping at 1.+predPos :: Pos -> Pos+predPos pos =+  mkPos $+  case unPos pos of+    1 -> 1+    atLeastTwo -> atLeastTwo - 1++-- | Computes the successor of a 'Pos' value.+succPos :: Pos -> Pos+succPos pos =+  mkPos $ unPos pos + 1++-- | Create, safely, as position. If a non-positive number is given,+-- we use 1.+--+safePos :: Int -> Pos+safePos i+  | i <= 0    = mkPos 1+  | otherwise = mkPos i++-- | Create a source position from integers, using 1 in case of+-- non-positive numbers.+safeSourcePos :: FilePath -> Int -> Int -> SourcePos+safeSourcePos file line col =+  SourcePos file (safePos line) (safePos col)++-----------------------------------------------------------------------+-- | Retrofitting instances to SourcePos ------------------------------+-----------------------------------------------------------------------++instance S.Store SourcePos where+  -- poke = S.poke . ofSourcePos+  -- peek = toSourcePos <$> S.peek+ instance Serialize SourcePos where   put = put . ofSourcePos   get = toSourcePos <$> get  instance PPrint SourcePos where-  pprintTidy _ = text . show+  pprintTidy _ = ppSourcePos  instance Hashable SourcePos where   hashWithSalt i   = hashWithSalt i . sourcePosElts +-- | This is a compatibility type synonym for megaparsec vs. parsec.+type SourceName = FilePath++-- | This is a compatibility type synonym for megaparsec vs. parsec.+type Line = Pos++-- | This is a compatibility type synonym for megaparsec vs. parsec.+type Column = Pos+ ofSourcePos :: SourcePos -> (SourceName, Line, Column) ofSourcePos p = (f, l, c)   where@@ -82,14 +145,15 @@    c = sourceColumn p  toSourcePos :: (SourceName, Line, Column) -> SourcePos-toSourcePos (f, l, c) = newPos f l c+toSourcePos (f, l, c) = SourcePos f l c  sourcePosElts :: SourcePos -> (SourceName, Line, Column)-sourcePosElts s = (src, line, col)+sourcePosElts = ofSourcePos++ppSourcePos :: SourcePos -> Doc+ppSourcePos z = text (printf "%s:%d:%d" f l c)   where-    src         = sourceName   s-    line        = sourceLine   s-    col         = sourceColumn s+    (f,l,c) = sourcePosElts $ z  instance Fixpoint SourcePos where   toFix = text . show@@ -121,7 +185,7 @@ instance Show a => Show (Located a) where   show (Loc l l' x)     | l == l' && l == dummyPos "Fixpoint.Types.dummyLoc" = show x ++ " (dummyLoc)"-    | otherwise  = show x ++ " defined from: " ++ show l ++ " to: " ++ show l'+    | otherwise  = show x ++ " defined at: " ++ render (ppSrcSpan (SS l l'))  instance PPrint a => PPrint (Located a) where   pprintTidy k (Loc _ _ x) = pprintTidy k x@@ -132,7 +196,7 @@ instance Ord a => Ord (Located a) where   compare x y = compare (val x) (val y) -instance (B.Binary a) => B.Binary (Located a)+instance (S.Store a) => S.Store (Located a)  instance Hashable a => Hashable (Located a) where   hashWithSalt i = hashWithSalt i . val@@ -140,9 +204,18 @@ instance (IsString a) => IsString (Located a) where   fromString = dummyLoc . fromString -srcLine :: (Loc a) => a -> Int -srcLine = sourceLine . sp_start . srcSpan +-- | We need the Binary instances for LH's spec serialization+instance B.Binary Pos where+  put = B.put . unPos+  get = mkPos <$> B.get +instance B.Binary SourcePos++instance (B.Binary a) => B.Binary (Located a)++srcLine :: (Loc a) => a -> Pos+srcLine = sourceLine . sp_start . srcSpan+ ----------------------------------------------------------------------- -- | A Reusable SrcSpan Type ------------------------------------------ -----------------------------------------------------------------------@@ -208,5 +281,5 @@   where     l    = dummyPos "Fixpoint.Types.dummyLoc" -dummyPos   :: String -> SourcePos-dummyPos s = newPos s 0 0+dummyPos   :: FilePath -> SourcePos+dummyPos = initialPos
src/Language/Fixpoint/Types/Substitutions.hs view
@@ -13,6 +13,8 @@   , subst1Except   , targetSubstSyms   , filterSubst+  , catSubst+  , exprSymbolsSet   ) where  import           Data.Maybe@@ -139,7 +141,7 @@   substf f (PImp p1 p2)    = PImp (substf f p1) (substf f p2)   substf f (PIff p1 p2)    = PIff (substf f p1) (substf f p2)   substf f (PAtom r e1 e2) = PAtom r (substf f e1) (substf f e2)-  substf _ p@(PKVar _ _)   = p+  substf f (PKVar k (Su su)) = PKVar k (Su $ M.map (substf f) su)   substf _  (PAll _ _)     = errorstar "substf: FORALL"   substf f (PGrad k su i e)= PGrad k su i (substf f e)   substf _  p              = p@@ -313,28 +315,9 @@     -- go (PAll xts p)       = (fst <$> xts) ++ go p     -- go _                  = [] + exprSymbols :: Expr -> [Symbol]-exprSymbols = S.toList . go -  where-    gos es                = S.unions (go <$> es)-    go (EVar x)           = S.singleton x-    go (EApp f e)         = gos [f, e] -    go (ELam (x,_) e)     = S.delete x (go e) -    go (ECoerc _ _ e)     = go e-    go (ENeg e)           = go e-    go (EBin _ e1 e2)     = gos [e1, e2] -    go (EIte p e1 e2)     = gos [p, e1, e2] -    go (ECst e _)         = go e-    go (PAnd ps)          = gos ps-    go (POr ps)           = gos ps-    go (PNot p)           = go p-    go (PIff p1 p2)       = gos [p1, p2] -    go (PImp p1 p2)       = gos [p1, p2]-    go (PAtom _ e1 e2)    = gos [e1, e2] -    go (PKVar _ (Su su))  = S.fromList $ syms $ M.elems su-    go (PAll xts p)       = go p `S.difference` S.fromList (fst <$> xts) -    go (PExist xts p)     = go p `S.difference` S.fromList (fst <$> xts) -    go _                  = S.empty +exprSymbols = S.toList . exprSymbolsSet  instance Expression (Symbol, SortedReft) where   expr (x, RR _ (Reft (v, r))) = subst1 (expr r) (v, EVar x)
src/Language/Fixpoint/Types/Theories.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE PatternGuards              #-}@@ -50,16 +51,24 @@  import           Text.PrettyPrint.HughesPJ.Compat 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.Binary              as B+import qualified Data.Store              as S import qualified Data.HashMap.Strict      as M import qualified Language.Fixpoint.Misc   as Misc +import Data.Functor.Contravariant (Contravariant(contramap))  -------------------------------------------------------------------------------- -- | 'Raw' is the low-level representation for SMT values ---------------------------------------------------------------------------------type Raw          = LT.Text+type Raw = LT.Text +instance S.Store Raw where+  peek = LT.fromStrict <$> S.peek  +  poke = S.poke . LT.toStrict+  size = contramap LT.toStrict S.size+ -------------------------------------------------------------------------------- -- | 'SymEnv' is used to resolve the 'Sort' and 'Sem' of each 'Symbol' --------------------------------------------------------------------------------@@ -77,7 +86,7 @@ type FuncSort = (SmtSort, SmtSort)  instance NFData   SymEnv-instance B.Binary SymEnv+instance S.Store SymEnv  instance Semigroup SymEnv where   e1 <> e2 = SymEnv { seSort   = seSort   e1 <> seSort   e2@@ -102,9 +111,11 @@ -- | 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 [(toIntName, mkFFunc 1 [FVar 0, FInt])]+wiredInEnv = M.fromList +  [ (toIntName, mkFFunc 1 [FVar 0, FInt])+  , (tyCastName, FAbs 0 $ FAbs 1 $ FFunc (FVar 0) (FVar 1))+  ]   -- | 'smtSorts' attempts to compute a list of all the input-output sorts@@ -149,11 +160,15 @@ insertsSymEnv :: SymEnv -> [(Symbol, Sort)] -> SymEnv insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env)  -symbolAtName :: (PPrint a) => Symbol -> SymEnv -> a -> Sort -> Symbol+symbolAtName :: (PPrint a) => Symbol -> SymEnv -> a -> Sort -> Text symbolAtName mkSym env e = symbolAtSmtName mkSym env e . ffuncSort env+{-# SCC symbolAtName #-} -symbolAtSmtName :: (PPrint a) => Symbol -> SymEnv -> a -> FuncSort -> Symbol-symbolAtSmtName mkSym env e = intSymbol mkSym . funcSortIndex env e+symbolAtSmtName :: (PPrint a) => Symbol -> SymEnv -> a -> FuncSort -> Text+symbolAtSmtName mkSym env e s =+  -- formerly: intSymbol mkSym . funcSortIndex env e+  appendSymbolText mkSym $ Text.pack (show (funcSortIndex env e s))+{-# SCC symbolAtSmtName #-}  funcSortIndex :: (PPrint a) => SymEnv -> a -> FuncSort -> Int funcSortIndex env e z = M.lookupDefault err z (seAppls env)@@ -187,7 +202,7 @@  instance NFData Sem instance NFData TheorySymbol-instance B.Binary TheorySymbol+instance S.Store TheorySymbol  instance PPrint Sem where   pprintTidy _ = text . show@@ -210,7 +225,7 @@   | Theory        -- ^ for theory ops: mem, cup, select   deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance B.Binary Sem+instance S.Store Sem   --------------------------------------------------------------------------------@@ -231,7 +246,7 @@  instance Hashable SmtSort instance NFData   SmtSort-instance B.Binary SmtSort+instance S.Store SmtSort  -- | The 'poly' parameter is True when we are *declaring* sorts, --   and so we need to leave the top type variables be; it is False when
src/Language/Fixpoint/Types/Triggers.hs view
@@ -12,7 +12,7 @@      ) where -import qualified Data.Binary as B+import qualified Data.Store as S import           Control.DeepSeq import           GHC.Generics              (Generic) import           Text.PrettyPrint.HughesPJ@@ -64,8 +64,8 @@ defaltPatter :: Expr defaltPatter = PFalse -instance B.Binary Trigger+instance S.Store Trigger instance NFData   Trigger -instance (B.Binary a) => B.Binary (Triggered a)+instance (S.Store a) => S.Store (Triggered a) instance (NFData a)   => NFData   (Triggered a)
src/Language/Fixpoint/Types/Utils.hs view
@@ -10,6 +10,11 @@    -- * Deconstruct a SortedReft   , sortedReftConcKVars++  -- * Operators on DataDecl+  , checkRegular+  , orderDeclarations+   ) where  import qualified Data.HashMap.Strict                  as M@@ -20,6 +25,8 @@ import           Language.Fixpoint.Types.Refinements import           Language.Fixpoint.Types.Environments import           Language.Fixpoint.Types.Constraints+import           Language.Fixpoint.Types.Sorts+import qualified Language.Fixpoint.Misc as Misc  -------------------------------------------------------------------------------- -- | Compute the domain of a kvar@@ -55,3 +62,83 @@     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)+++-------------------------------------------------------------------------------+-- | @checkRegular ds@ returns the subset of ds that are _not_ regular+-------------------------------------------------------------------------------+checkRegular :: [DataDecl] -> [DataDecl]+-------------------------------------------------------------------------------+checkRegular ds = concat [ ds' | ds' <- orderDeclarations ds, not (isRegular ds')]++-------------------------------------------------------------------------------+-- | @isRegular [d1,...]@ gets a non-empty list of mut-recursive datadecls+-------------------------------------------------------------------------------+isRegular :: [DataDecl] -> Bool+-------------------------------------------------------------------------------++isRegular []       = error "impossible: isRegular"+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 +                              , (c, ts)     <- sortApps t+                     ]         +    isRegApp cts   = case cts of +                        (FTC c, ts) -> not (S.member (symbol c) tcs) || isRegularArgs nArgs ts+                        _           -> False++isRegularArgs :: Int -> [Sort] -> Bool+isRegularArgs n ts = ts == [FVar i | i <- [0 .. (n-1)]]++type SortApp = (Sort, [Sort])++sortApps :: Sort -> [SortApp]+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 = go []+  where+    go stk (FApp t1 t2) = go (t2:stk) t1  +    go stk t            = (t, stk)++--------------------------------------------------------------------------------+-- | 'orderDeclarations' sorts the data declarations such that each declarations+--   only refers to preceding ones.+--------------------------------------------------------------------------------+orderDeclarations :: [DataDecl] -> [[DataDecl]]+--------------------------------------------------------------------------------+orderDeclarations ds = {- reverse -} Misc.sccsWith f ds+  where+    dM               = M.fromList [(ddTyCon d, d) | d <- ds]+    f d              = (ddTyCon d, dataDeclDeps dM d)++dataDeclDeps :: M.HashMap FTycon DataDecl -> DataDecl -> [FTycon]+dataDeclDeps dM = filter (`M.member` dM) . Misc.sortNub . dataDeclFTycons++dataDeclFTycons :: DataDecl -> [FTycon]+dataDeclFTycons = concatMap dataCtorFTycons . ddCtors++dataCtorFTycons :: DataCtor -> [FTycon]+dataCtorFTycons = concatMap dataFieldFTycons . dcFields++dataFieldFTycons :: DataField -> [FTycon]+dataFieldFTycons = sortFTycons . dfSort++sortFTycons :: Sort -> [FTycon]+sortFTycons = go+  where+    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 _             = []
src/Language/Fixpoint/Types/Visitor.hs view
@@ -26,20 +26,20 @@    -- * Clients   , stripCasts-  , kvars, eapps+  , kvarsExpr, eapps   , size, lamSize   , envKVars   , envKVarsN   , rhsKVars   , mapKVars, mapKVars', mapGVars', mapKVarSubsts-  , mapExpr, mapMExpr+  , mapExpr, mapExprOnExpr, mapMExpr    -- * Coercion Substitutions   , CoSub   , applyCoSub    -- * Predicates on Constraints-  , isConcC , isKvarC+  , isConcC , isConc, isKvarC    -- * Sorts   , foldSort@@ -124,7 +124,7 @@   visit = visitExpr  instance Visitable Reft where-  visit v c (Reft (x, ra)) = (Reft . (x, )) <$> visit v c ra+  visit v c (Reft (x, ra)) = Reft . (x, ) <$> visit v c ra  instance Visitable SortedReft where   visit v c (RR t r) = RR t <$> visit v c r@@ -176,8 +176,8 @@ 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@@ -232,7 +232,35 @@ mapExpr :: Visitable t => (Expr -> Expr) -> t -> t mapExpr f = trans (defaultVisitor {txExpr = const f}) () () +-- | Specialized and faster version of mapExpr for expressions+mapExprOnExpr :: (Expr -> Expr) -> Expr -> Expr+mapExprOnExpr f = go+  where+    go e0 = f $ case e0 of+      EApp f e -> EApp (go f) (go e)+      ENeg e -> ENeg (go e)+      EBin o e1 e2 ->  EBin o (go e1) (go e2)+      EIte p e1 e2 -> EIte (go p) (go e1) (go e2)+      ECst e t -> ECst (go e) t+      PAnd ps -> PAnd (map go ps)+      POr ps -> POr (map go ps)+      PNot p -> PNot (go p)+      PImp p1 p2 -> PImp (go p1) (go p2)+      PIff p1 p2 -> PIff (go p1) (go p2)+      PAtom r e1 e2 -> PAtom r (go e1) (go e2)+      PAll xts p -> PAll xts (go p)+      ELam (x,t) e -> ELam (x,t) (go e)+      ECoerc a t e -> ECoerc a t (go e)+      PExist xts p -> PExist xts (go p)+      ETApp e s -> ETApp (go e) s+      ETAbs e s -> ETAbs (go e) s+      PGrad k su i e -> PGrad k su i (go e)+      e@PKVar{} -> e+      e@EVar{} -> e+      e@ESym{} -> e+      e@ECon{} -> e + mapMExpr :: (Monad m) => (Expr -> m Expr) -> Expr -> m Expr mapMExpr f = go   where@@ -298,28 +326,48 @@     eapp' _ e@(EApp _ _) = [e]     eapp' _ _            = [] -kvars :: Visitable t => t -> [KVar]-kvars                 = fold kvVis () []+{-# SCC kvarsExpr #-}+kvarsExpr :: Expr -> [KVar]+kvarsExpr = go []   where-    kvVis             = (defaultVisitor :: Visitor [KVar] t) { accExpr = kv' }-    kv' _ (PKVar k _)     = [k]-    kv' _ (PGrad k _ _ _) = [k]-    kv' _ _               = []+    go acc e0 = case e0 of+      ESym _ -> acc+      ECon _ -> acc+      EVar _ -> acc+      PKVar k _ -> k : acc+      PGrad k _ _ _ -> k : acc+      ENeg e -> go acc e+      PNot p -> go acc p+      ECst e _t -> go acc e+      PAll _xts p -> go acc p+      ELam _b e -> go acc e+      ECoerc _a _t e -> go acc e+      PExist _xts p -> go acc p+      ETApp e _s -> go acc e+      ETAbs e _s -> go acc e+      EApp g e -> go (go acc e) g+      EBin _o e1 e2 -> go (go acc e2) e1+      PImp p1 p2 -> go (go acc p2) p1+      PIff p1 p2 -> go (go acc p2) p1+      PAtom _r e1 e2 -> go (go acc e2) e1+      EIte p e1 e2 -> go (go (go acc e2) e1) p+      PAnd ps -> foldr (flip go) acc ps+      POr ps -> foldr (flip go) acc ps  envKVars :: (TaggedC c a) => BindEnv -> c a -> [KVar] envKVars be c = squish [ kvs sr |  (_, sr) <- clhs be c]   where     squish    = S.toList  . S.fromList . concat-    kvs       = kvars . sr_reft+    kvs       = kvarsExpr . reftPred . sr_reft  envKVarsN :: (TaggedC c a) => BindEnv -> c a -> [(KVar, Int)] envKVarsN be c = tally [ kvs sr |  (_, sr) <- clhs be c]   where     tally      = Misc.count . concat-    kvs        = kvars . sr_reft+    kvs        = kvarsExpr . reftPred . sr_reft  rhsKVars :: (TaggedC c a) => c a -> [KVar]-rhsKVars = kvars . crhs -- rhsCs+rhsKVars = kvarsExpr . crhs -- rhsCs  isKvarC :: (TaggedC c a) => c a -> Bool isKvarC = all isKvar . conjuncts . crhs@@ -333,10 +381,10 @@ isKvar _          = False  isConc :: Expr -> Bool-isConc = null . kvars+isConc = null . kvarsExpr -stripCasts :: (Visitable t) => t -> t-stripCasts = trans (defaultVisitor { txExpr = const go }) () ()+stripCasts :: Expr -> Expr+stripCasts = mapExprOnExpr go   where     go (ECst e _) = e     go e          = e@@ -403,6 +451,20 @@  class SymConsts a where   symConsts :: a -> [SymConst]+++instance SymConsts a => SymConsts [a] 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 Rewrite where +  symConsts = symConsts . smBody +  -- instance  SymConsts (FInfo a) where instance (SymConsts (c a)) => SymConsts (GInfo c a) where
+ src/Language/Fixpoint/Utils/Builder.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings    #-}++-- | Wrapper around `Data.Text.Builder` that exports some useful combinators++module Language.Fixpoint.Utils.Builder+  ( Builder+  , fromLazyText+  , fromString+  , fromText+  , toLazyText+  , parens+  , (<+>)+  , parenSeqs+  , seqs+  , key+  , key2+  , key3+  , bShow+  , bFloat+  , bb+  , lbb+  , blt+  ) where++import           Data.String+import qualified Data.Text.Lazy.Builder as B+import qualified Data.Text.Lazy         as LT+import qualified Data.Text              as T+import qualified Data.List              as L+import qualified Numeric++-- | Offers efficient concatenation, no matter the associativity+data Builder+  = Node Builder Builder+  | Leaf B.Builder++instance Eq Builder where+  b0 == b1 = toLazyText b0 == toLazyText b1++instance IsString Builder where+  fromString = Leaf . fromString++instance Semigroup Builder where+  (<>) = Node++instance Monoid Builder where+  mempty = Leaf mempty++toLazyText :: Builder -> LT.Text+toLazyText = B.toLazyText . go mempty+  where+    go tl (Leaf b) = b <> tl+    go tl (Node t0 t1) = go (go tl t1) t0++fromLazyText :: LT.Text -> Builder+fromLazyText = Leaf . B.fromLazyText++fromText :: T.Text -> Builder+fromText = Leaf . B.fromText++parens :: Builder -> Builder+parens b = "(" <>  b <> ")"++(<+>) :: Builder -> Builder -> Builder+x <+> y = x <> " " <> y++parenSeqs :: [Builder] -> Builder+parenSeqs = parens . seqs++key :: Builder -> Builder -> Builder+key k b = parenSeqs [k, b]++key2 :: Builder -> Builder -> Builder -> Builder+key2 k b1 b2 = parenSeqs [k, b1, b2]++key3 :: Builder -> Builder -> Builder -> Builder ->  Builder+key3 k b1 b2 b3 = parenSeqs [k, b1, b2, b3]++seqs :: [Builder] -> Builder+seqs = foldr (<>) mempty . L.intersperse " "++bShow :: Show a => a -> Builder+bShow = fromString . show++bFloat :: RealFloat a => a -> Builder+bFloat d = fromString (Numeric.showFFloat Nothing d "")++bb :: LT.Text -> Builder+bb = fromLazyText++lbb :: T.Text -> Builder+lbb = bb . LT.fromStrict++blt :: Builder -> LT.Text+blt = toLazyText+
src/Language/Fixpoint/Utils/Files.hs view
@@ -90,6 +90,7 @@          | Dat          | BinFq    -- ^ Binary representation of .fq / FInfo          | Smt2     -- ^ SMTLIB2 query file+         | HSmt2    -- ^ Horn query file          | Min      -- ^ filter constraints with delta debug          | MinQuals -- ^ filter qualifiers with delta debug          | MinKVars -- ^ filter kvars with delta debug@@ -122,6 +123,7 @@     go Saved    = ".bak"     go Cache    = ".err"     go Smt2     = ".smt2"+    go HSmt2    = ".horn.smt2"     go (Auto n) = ".auto." ++ show n     go Dot      = ".dot"     go BinFq    = ".bfq"
+ stack.yaml view
@@ -0,0 +1,20 @@++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
+ tests/crash/EqConstr0.fq view
@@ -0,0 +1,9 @@+ +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 []
+ tests/crash/EqConstr1.fq view
@@ -0,0 +1,12 @@+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 []
+ tests/crash/num00.fq view
@@ -0,0 +1,29 @@+// 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}
+ tests/crash/sort00.fq view
@@ -0,0 +1,12 @@+// 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 []+
+ tests/crash/sort01.fq view
@@ -0,0 +1,13 @@+// 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 []+
+ tests/cut/test00-tx.fq view
@@ -0,0 +1,12 @@+++// 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
+ tests/cut/test00.fq view
@@ -0,0 +1,28 @@+++// 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}
+ tests/cut/test00a-tx.fq view
@@ -0,0 +1,43 @@+// 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 ++*/
+ tests/cut/test00a.fq view
@@ -0,0 +1,29 @@+// 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}+
+ tests/cut/test1-tx.fq view
@@ -0,0 +1,43 @@++// 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++*/
+ tests/cut/test1.fq view
@@ -0,0 +1,29 @@++// 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}
+ tests/cut/test2-tx.fq view
@@ -0,0 +1,112 @@++// 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
+ tests/cut/test2.fq view
@@ -0,0 +1,51 @@++// 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}
+ tests/elim/div00.fq view
@@ -0,0 +1,23 @@++// --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 }
+ tests/elim/elim00.fq view
@@ -0,0 +1,1494 @@+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 : ()
+ tests/elim/kvparam00.fq view
@@ -0,0 +1,20 @@+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]}+
+ tests/elim/len00.fq view
@@ -0,0 +1,23 @@++// 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] }
+ tests/elim/test00-tx.fq view
@@ -0,0 +1,12 @@+++// 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 []
+ tests/elim/test00.fq view
@@ -0,0 +1,26 @@+// 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}
+ tests/elim/test00a.fq view
@@ -0,0 +1,28 @@+// 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}
+ tests/elim/test1.fq view
@@ -0,0 +1,29 @@++// 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}
+ tests/elim/test2.fq view
@@ -0,0 +1,53 @@++// 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}
+ tests/elim/tuple00.fq view
@@ -0,0 +1,114 @@++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}
+ tests/elim/tuple01.fq view
@@ -0,0 +1,137 @@+// 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}
+ tests/horn/neg/abs02-re.smt2 view
@@ -0,0 +1,29 @@+(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))))))))))
+ tests/horn/neg/ebind03.smt2 view
@@ -0,0 +1,16 @@+(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)))))
+ tests/horn/neg/irregular_adt_00.smt2 view
@@ -0,0 +1,36 @@+// 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)))+      )+    )+  )+)
+ tests/horn/neg/ple0.smt2 view
@@ -0,0 +1,13 @@+(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 ))+     )+   )+)
+ tests/horn/neg/ple_list00.smt2 view
@@ -0,0 +1,12 @@+(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))+)
+ tests/horn/neg/ple_list01_adt.smt2 view
@@ -0,0 +1,22 @@+(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))+      )+    )+  )+)
+ tests/horn/neg/ple_list03.smt2 view
@@ -0,0 +1,45 @@+(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))+)
+ tests/horn/neg/ple_sum.smt2 view
@@ -0,0 +1,12 @@+(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 ))+   )+)+
+ tests/horn/neg/ple_sum_fuel.5.smt2 view
@@ -0,0 +1,14 @@+(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)))+   )+)+
+ tests/horn/neg/tag00.smt2 view
@@ -0,0 +1,16 @@+(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" )))))+)++
+ tests/horn/neg/test00.smt2 view
@@ -0,0 +1,10 @@+(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)))))+)
+ tests/horn/neg/test01.smt2 view
@@ -0,0 +1,16 @@+(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" )))))+)++
+ tests/horn/neg/test02.smt2 view
@@ -0,0 +1,18 @@+(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)))))))+
+ tests/horn/neg/test03.smt2 view
@@ -0,0 +1,24 @@+(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)))))++++++
+ tests/horn/pos/abs02-re.smt2 view
@@ -0,0 +1,13 @@+(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)))))))))
+ tests/horn/pos/constant.smt2 view
@@ -0,0 +1,13 @@+(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])))
+ tests/horn/pos/ebind01.smt2 view
@@ -0,0 +1,6 @@+(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)))))))
+ tests/horn/pos/ebind02.smt2 view
@@ -0,0 +1,11 @@+(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)))))))))
+ tests/horn/pos/ebind03.smt2 view
@@ -0,0 +1,14 @@+(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)))))
+ tests/horn/pos/icfp17-ex1.smt2 view
@@ -0,0 +1,14 @@+(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)))))))++
+ tests/horn/pos/icfp17-ex2.smt2 view
@@ -0,0 +1,19 @@+(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)))))))++
+ tests/horn/pos/icfp17-ex3.smt2 view
@@ -0,0 +1,16 @@+(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)))))+
+ tests/horn/pos/ple0.smt2 view
@@ -0,0 +1,13 @@+(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 ))+     )+   )+)
+ tests/horn/pos/ple_list00.smt2 view
@@ -0,0 +1,18 @@+(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))+      )+    )+  )+)
+ tests/horn/pos/ple_list01_adt.smt2 view
@@ -0,0 +1,23 @@+(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))+      )+    )+  )+)
+ tests/horn/pos/ple_sum.smt2 view
@@ -0,0 +1,13 @@+(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 ))+   )+)+
+ tests/horn/pos/ple_sum_fuel.5.smt2 view
@@ -0,0 +1,14 @@+(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)))+   )+)+
+ tests/horn/pos/sum-rec-ok.smt2 view
@@ -0,0 +1,24 @@+(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)))))))) ++
+ tests/horn/pos/sum-rec.smt2 view
@@ -0,0 +1,24 @@+(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)))))))) ++
+ tests/horn/pos/test00.smt2 view
@@ -0,0 +1,15 @@+// 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))))))
+ tests/horn/pos/test01.smt2 view
@@ -0,0 +1,12 @@+// 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)))))))
+ tests/horn/pos/test02.smt2 view
@@ -0,0 +1,18 @@+// 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)))))))++
+ tests/horn/pos/test03.smt2 view
@@ -0,0 +1,22 @@+// 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)))))++++++
+ tests/minimize/two-cores.fq view
@@ -0,0 +1,30 @@+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]}
+ tests/neg/EqParse.fq view
@@ -0,0 +1,21 @@+bind 0 func0_x0 : {b: int | true}+bind 1 func0_x1 : {b: int | true}+bind 2 func0_x2 : {b: int | true}+bind 3 func0_x3 : {b: int | true}+bind 4 func0_x4 : {b: int | true}+bind 5 func0_x5 : {b: bool | true}+bind 6 func0_x6 : {b: int | (b = func0_x1)}+bind 7 func0_x7 : {b: int | (b = func0_x2)}+bind 8 func0_x8 : {b: bool | (b = (func0_x7 = 0))}+bind 9 func0_x9 : {b: int | (b = (func0_x6 / func0_x7))}+constraint:+        env [1;2;7;8]+        lhs {b: bool | true }+        rhs {b: bool | (b = false)}+        id 0 tag []++constraint:+        env [1; 2; 6; 7]+        lhs {b: int | (b = (func0_x6 / func0_x7))}+        rhs {b: int | (b = (func0_x1 / func0_x2))}+        id 1 tag []
tests/neg/literals.fq view
@@ -1,4 +1,4 @@-//adapted from LH test Strings.hs+// adapted from LH test Strings.hs  constant lit#bar : (Str) constant lit#foo : (Str)
tests/pos/bool03.fq view
@@ -1,5 +1,5 @@ -//qualif LE(v:a, x:a): (bool_to_int x <= bool_to_int v)+// qualif LE(v:a, x:a): (bool_to_int x <= bool_to_int v)  qualif LE(v:a, x:a): (x <= v)
tests/pos/float.fq view
@@ -2,10 +2,10 @@  bind 50 x : {v1 : real | [(v1 = 0.2)]} bind 56 y : {v2 : real | [(v2 = 0.8 + x)]}+bind 57 z : {v3 : real | [(v3 = 0.00014)]}   constraint:-  env [50;-       56]+  env [50; 56; 57]   lhs {VV#F3 : int | []}   rhs {VV#F3 : int | [(y = 1.0)]}   id 3 tag [1]
tests/pos/literals.fq view
@@ -1,4 +1,4 @@-//adapted from LH test Strings.hs+// adapted from LH test Strings.hs  constant lit#bar : (Str) constant lit#foo : (Str)
+ tests/pos/undef00.fq view
@@ -0,0 +1,17 @@+++bind 1 undef1 : {v: func(1, [@(0)]) | []}+bind 2 undef2 : {v: func(2, [@(1)]) | []}++constraint:+  env [1]+  lhs {v : bool | [v = undef1]}+  rhs {v : bool | [0 < 7]}+  id 1 tag []++constraint:+  env [2]+  lhs {v : bool | [v = undef2]}+  rhs {v : bool | [0 < 7]}+  id 2 tag []+
+ tests/pos/undef01.fq view
@@ -0,0 +1,14 @@++data LL 1 = [+  | emp { }+  | con { lHead : @(0), lTail : LL @(0) }+]++bind 1 undef : {v: func(1, [@(0)]) | []}++constraint:+  env [1]+  lhs {v : LL int | [v = undef]}+  rhs {v : LL int | [0 < 7]}+  id 1 tag []+
+ tests/proof/GADTs.fq view
@@ -0,0 +1,29 @@++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]
+ tests/proof/IndPal00.fq view
@@ -0,0 +1,440 @@+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))]))++
+ tests/proof/IndPal000.fq view
@@ -0,0 +1,23 @@+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 []++
+ tests/proof/LH1424.fq view
@@ -0,0 +1,42 @@+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 []+++++++
+ tests/proof/T387.fq view
@@ -0,0 +1,27 @@+// 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 []
+ tests/proof/T414.fq view
@@ -0,0 +1,27 @@+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 []
+ tests/proof/contra.fq view
@@ -0,0 +1,22 @@+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 []
+ tests/proof/even.fq view
@@ -0,0 +1,35 @@+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]
+ tests/proof/evenA.fq view
@@ -0,0 +1,33 @@+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]
+ tests/proof/intId.fq view
@@ -0,0 +1,17 @@+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 []
+ tests/proof/list00.fq view
@@ -0,0 +1,16 @@+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]
+ tests/proof/list01.fq view
@@ -0,0 +1,26 @@+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]
+ tests/proof/list01_adt.fq view
@@ -0,0 +1,20 @@+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]
+ tests/proof/list02.fq view
@@ -0,0 +1,29 @@+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]
+ tests/proof/list03.fq view
@@ -0,0 +1,52 @@+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]
+ tests/proof/ple0.fq view
@@ -0,0 +1,13 @@+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 []
+ tests/proof/ple1.fq view
@@ -0,0 +1,17 @@+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 []
+ tests/proof/ple2.fq view
@@ -0,0 +1,19 @@+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 []+
+ tests/proof/ple3.fq view
@@ -0,0 +1,40 @@+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 []
+ tests/proof/ple4.fq view
@@ -0,0 +1,30 @@+// 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 []
+ tests/proof/pleBool.fq view
@@ -0,0 +1,23 @@+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 []
+ tests/proof/pleBoolA.fq view
@@ -0,0 +1,50 @@+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 []
+ tests/proof/pleBoolB.fq view
@@ -0,0 +1,55 @@+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 []
+ tests/proof/pleBoolC.fq view
@@ -0,0 +1,57 @@+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 []
+ tests/proof/pleSubst.fq view
@@ -0,0 +1,18 @@+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 []
+ tests/proof/rewrite.fq view
@@ -0,0 +1,61 @@+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 []
+ tests/proof/sum.fq view
@@ -0,0 +1,19 @@+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 []++
+ tests/rankNTypes/T407.hs.fq view
@@ -0,0 +1,17 @@++// 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 []
+ tests/tasty/Main.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified ParserTests+import qualified ShareMapTests+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain $ testGroup "Tests"+  [ ParserTests.tests+  , ShareMapTests.tests+  ]
+ tests/tasty/ParserTests.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE OverloadedStrings #-}++module ParserTests (tests) where++import Language.Fixpoint.Types (showFix)+import Language.Fixpoint.Parse+import Test.Tasty+import Test.Tasty.HUnit+import Data.List (intercalate)++tests :: TestTree+tests =+  testGroup "ParserTests"+    [ testSortP+    , testFunAppP+    , testExpr0P+    , testPredP+    , testDeclP+    ]++-- ---------------------------------------------------------------------+{-++sort = '(' sort ')'+     | 'func' funcSort+     | '[' sort ']'+     | bvsort+     | fTyCon+     | tVar++sorts = '[' sortslist ']'++sortslist = sort+          | sort `;` sortslist++funcSort = '(' int `,` sorts ')'++     e.g.(func(1, [int; @(0)]))++bvsort = '(' 'BitVec' 'Size32' ')'+       | '(' 'BitVec' 'Size64' ')'++fTyCon = 'int' | 'Integer' | 'Int' | 'real' | 'num' | 'Str'+       | SYMBOL++SYMBOL = upper case char or _, followed by many of '%' '#' '$' '\'++tVar = '@' varSort+     | LOWERID++varSort = '(' INT ')'+-}++testSortP :: TestTree+testSortP =+  testGroup "SortP"+    [ testCase "FAbs" $+        show (doParse' sortP "test" "(func(1, [int; @(0)]))") @?= "FAbs 0 (FFunc FInt (FVar 0))"++    , testCase "(FAbs)" $+        show (doParse' sortP "test" "((func(1, [int; @(0)])))") @?= "FAbs 0 (FFunc FInt (FVar 0))"++    , testCase "FApp FInt" $+        show (doParse' sortP "test" "[int]") @?=+              "FApp (FTC (TC \"[]\" (dummyLoc) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) FInt"++    , testCase "bv32" $+        show (doParse' sortP "test" "BitVec Size32") @?=+              "FApp (FTC (TC \"BitVec\" defined at: test:1:1-1:7 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) (FTC (TC \"Size32\" defined at: test:1:8-1:14 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False})))"++    , testCase "bv64" $+        show (doParse' sortP "test" "BitVec Size64") @?=+              "FApp (FTC (TC \"BitVec\" defined at: test:1:1-1:7 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) (FTC (TC \"Size64\" defined at: test:1:8-1:14 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False})))"++    , testCase "FInt int" $+        show (doParse' sortP "test" "int") @?= "FInt"++    , testCase "FInt Integer" $+        show (doParse' sortP "test" "Integer") @?= "FInt"++    , testCase "FInt Int" $+        show (doParse' sortP "test" "Int") @?= "FInt"++    , testCase "FReal real" $+        show (doParse' sortP "test" "real") @?= "FReal"++    , testCase "FNum num" $+        show (doParse' sortP "test" "num") @?= "FNum"++    , testCase "FStr" $+        show (doParse' sortP "test" "Str") @?=+             "FTC (TC \"Str\" (dummyLoc) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = True}))"++    , testCase "SYMBOL" $+        show (doParse' sortP "test" "F#y") @?=+             "FTC (TC \"F#y\" defined at: test:1:1-1:4 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))"++    , testCase "FVar 3" $+        show (doParse' sortP "test" "@(3)") @?= "FVar 3"++    , testCase "FObj " $+        show (doParse' sortP "test" "foo") @?= "FObj \"foo\""++    , testCase "FObj " $+        show (doParse' sortP "test" "_foo") @?= "FObj \"_foo\""++    , testCase "Coerce0" $+        show (doParse' predP "test" "v = (coerce (a ~ int) (f x))")+          @?= "PAtom Eq (EVar \"v\") (ECoerc (FObj \"a\") FInt (EApp (EVar \"f\") (EVar \"x\")))"+    ]++-- ---------------------------------------------------------------------+{-++funApp = lit+       | exprFunSpaces+       | expFunSemis+       | expFunCommas+       | simpleApp++lit = 'lit' stringLiteral sort++exprFunSpaces =++exprFunSemis =++exprFunCommas =++simpleApp =+-}+testFunAppP :: TestTree+testFunAppP =+  testGroup "FunAppP"+    [ testCase "ECon (litP)" $+        show (doParse' funAppP "test" "lit \"#x00000008\" (BitVec  Size32)") @?=+          "ECon (L \"#x00000008\" (FApp (FTC (TC \"BitVec\" defined at: test:1:19-1:25 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) (FTC (TC \"Size32\" defined at: test:1:27-1:33 (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False})))))"++    , testCase "ECon (exprFunSpacesP)" $+        show (doParse' funAppP "test" "fooBar baz qux") @?= "EApp (EApp (EVar \"fooBar\") (EVar \"baz\")) (EVar \"qux\")"++    , testCase "ECon (exprFunCommasP)" $+        show (doParse' funAppP "test" "fooBar (baz, qux)") @?= "EApp (EVar \"fooBar\") (EApp (EApp (EVar \"(,)\") (EVar \"baz\")) (EVar \"qux\"))"++    , testCase "ECon (exprFunSemisP)" $+        show (doParse' funAppP "test" "fooBar ([baz; qux])") @?= "EApp (EApp (EVar \"fooBar\") (EVar \"baz\")) (EVar \"qux\")"++    , testCase "ECon (simpleAppP)" $+        show (doParse' funAppP "test" "fooBar (baz + 1)") @?= "EApp (EVar \"fooBar\") (EBin Plus (EVar \"baz\") (ECon (I 1)))"+    ]++-- ---------------------------------------------------------------------+{-+expr0 = fastIf+      | symconst+      | constant+      | '_|_'+      | lam+      | '(' expr ')'+      | '(' exprCast ')'+      | symChars++-}+testExpr0P :: TestTree+testExpr0P =+  testGroup "expr0P"+    [ testCase "EIte" $+        show (doParse' expr0P "test" "if true then x else y") @?= "EIte (PAnd []) (EVar \"x\") (EVar \"y\")"++    , testCase "ESym SL" $+        show (doParse' expr0P "test" "\"foo\" ") @?= "ESym (SL \"foo\")"++    , testCase "ECon R" $+        show (doParse' expr0P "test" "0.0") @?= "ECon (R 0.0)"++    , testCase "ECon I" $+        show (doParse' expr0P "test" "0") @?= "ECon (I 0)"++    , testCase "ECon I" $+        show (doParse' expr0P "test" "0") @?= "ECon (I 0)"++    , testCase "EBot / POr []" $+        show (doParse' expr0P "test" "_|_") @?= "POr []" -- pattern for "EBot"++    , testCase "ELam" $+        show (doParse' expr0P "test" "\\ foo : Int -> true") @?= "ELam (\"foo\",FInt) (PAnd [])"++    , testCase "Expr" $+        show (doParse' expr0P "test" "(1)") @?= "ECon (I 1)"++    , testCase "ECst dcolon" $+        show (doParse' expr0P "test" "(1 :: Int)") @?= "ECst (ECon (I 1)) FInt"++    , testCase "ECst colon" $+        show (doParse' expr0P "test" "(1 : Int)") @?= "ECst (ECon (I 1)) FInt"++    , testCase "charsExpr EVar" $+        show (doParse' expr0P "test" "foo") @?= "EVar \"foo\""++    , testCase "charsExpr ECon" $+        show (doParse' expr0P "test" "1") @?= "ECon (I 1)"+    ]++-- ---------------------------------------------------------------------+{-++pred = expressionParse (prefixOp++infixOp) pred0++prefixOp = '~' | 'not'++infixOp  = '&&' | '||' | '=>' | '==>' | '<=>'++-- terms are pred0+pred0 = 'true' | 'false'+      | '??'+      | kvarPred+      | fastIfP+      | predr+      | '(' pred ')'+      | '?' expr+      | funApp+      | symbol+      | '&&' preds+      | '||' preds++kvarPred = kvar substs++kvar = '$' symbol++substs = {- empty -}+       | subst substs++subst = '[' symbol ':=' expr ']'++preds = '[' predslist ']'++predslist = pred+          | pred `;` predslist++fastIf = 'if' pred 'then' pred 'else' pred++predr = expr brel expr++brelP = '==' | '=' | '~~' | '!=' | '/=' | '!~' | '<' | '<=' | '>' | '>='++-}++testPredP :: TestTree+testPredP =+  testGroup "predP"+    [ testCase "PTrue" $+        show (doParse' predP "test" "true") @?= "PAnd []" -- pattern for PTrue++    , testCase "PFalse" $+        show (doParse' predP "test" "false") @?= "POr []" -- pattern for PFalse++   --     , testCase "PGrad / ??" $+   --       show (doParse' predP "test" "??") @?= "PGrad $\"\\\"test\\\" (line 1, column 3)\"  (PAnd [])"+   --   "PGrad $\"\\\"test\\\" (line 1, column 3)\"  (GradInfo {gsrc = SS {sp_start = \"test\" (line 1, column 3), sp_stop = \"test\" (line 1, column 3)}, gused = Nothing}) (PAnd [])"++    , testCase "kvarPred empty" $+        show (doParse' predP "test" "$foo") @?= "PKVar $\"foo\" "++    , testCase "kvarPred one" $+        show (doParse' predP "test" "$foo  [x := 1]") @?= "PKVar $\"foo\" [x:=1]"++    , testCase "kvarPred two" $+        show (doParse' predP "test" "$foo  [x := 1] [ y := true ]") @?= "PKVar $\"foo\" [x:=1][y:=true]"++    , testCase "fastIf" $+        show (doParse' predP "test" "if true then true else false" ) @?=+          -- note conversion+          "PAnd [PImp (PAnd []) (PAnd []),PImp (PNot (PAnd [])) (POr [])]"++    , testCase "brel" $+        show (doParse' predP "test" "1 == 2") @?= "PAtom Eq (ECon (I 1)) (ECon (I 2))"++    , testCase "parens pred" $+        show (doParse' predP "test" "((1 == 2))") @?= "PAtom Eq (ECon (I 1)) (ECon (I 2))"++    , testCase "? expr" $+        show (doParse' predP "test" "? (1+2)") @?= "EBin Plus (ECon (I 1)) (ECon (I 2))"++    , testCase "funApp 1" $+        show (doParse' predP "test" "f a b") @?= "EApp (EApp (EVar \"f\") (EVar \"a\")) (EVar \"b\")"++    , testCase "funApp 2" $+        show (doParse' predP "test" "f (a, b)") @?= "EApp (EVar \"f\") (EApp (EApp (EVar \"(,)\") (EVar \"a\")) (EVar \"b\"))"++    , testCase "funApp 3" $+        show (doParse' predP "test" "f ([a; b])") @?= "EApp (EApp (EVar \"f\") (EVar \"a\")) (EVar \"b\")"++    , testCase "symbol" $+        show (doParse' predP "test" "f") @?= "EVar \"f\""++    , testCase "&& 0" $+        show (doParse' predP "test" "&& []") @?= "PAnd []"++    , testCase "&& 1" $+        show (doParse' predP "test" "&& [x]") @?= "EVar \"x\""++    , testCase "&& 2" $+        show (doParse' predP "test" "&& [x;y]") @?= "PAnd [EVar \"x\",EVar \"y\"]"++    , testCase "|| 0" $+        show (doParse' predP "test" "|| []") @?= "POr []"++    , testCase "|| 1" $+        show (doParse' predP "test" "|| [x]") @?= "POr [EVar \"x\"]"++    , testCase "|| 2" $+        show (doParse' predP "test" "|| [x;y]") @?= "POr [EVar \"x\",EVar \"y\"]"+    ]+++{-++data Vec 1 = [+    Nil {}+  | Cons { vHead : @(0), vTail : Vec @(0)}+  ]++-}++testDeclP :: TestTree+testDeclP = testGroup "dataDeclP"+  [ mkT "fld0"  dataFieldP fld0+  , mkT "fld1"  dataFieldP fld1+  , mkT "fld2"  dataFieldP fld2+  , mkT "ctor0" dataCtorP  ctor0+  , mkT "ctor1" dataCtorP  ctor1+  , mkT "decl0" dataDeclP decl0+  ]+  where+    mkT name p t = testCase name $ showFix (doParse' p "test" t) @?= t+    fld0    = "vHead : int"+    fld1    = "vHead : @(0)"+    fld2    = "vTail : (Vec @(0))"+    ctor0   = "nil {}"+    ctor1   = "cons {vHead : @(0), vTail : (Vec @(0))}"+    decl0   = intercalate "\n"+                [ "Vec 1 = ["+                , "  | nil {}"+                , "  | cons {vHead : @(0), vTail : Vec}"+                , "]"+                ]
+ tests/tasty/ShareMapReference.hs view
@@ -0,0 +1,85 @@+-- | A reference implementation for Data.ShareMap+module ShareMapReference where++import           Data.Hashable (Hashable)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import           Data.List (find)++-- | See "Data.ShareMap" for documentation.+data ShareMap k v = ShareMap+  { -- | Contains all the values in the ShareMap.+    toHashMap :: HashMap k v+  , -- | Contains all the keys in the ShareMap.+    --+    -- All sets in @keyPartitions@ are disjoint.+    -- Every key in in @keyPartitions@ is present in @toHashMap@.+    -- If @k1@ and @k2@ belong to the same set @s@ in @keyPartitions@+    -- then @toHashMap ! k1 == toHashMap ! k2@.+    keyPartitions :: [HashSet k]+  }+  deriving Show++empty :: ShareMap k v+empty = ShareMap HashMap.empty []++insertWith+  :: (Hashable k, Eq k)+  => (v -> v -> v)+  -> k+  -> v+  -> ShareMap k v+  -> ShareMap k v+insertWith f k v sm =+  let h = toHashMap sm+      ks = keyPartitions sm+   in case find (HashSet.member k) ks of+     Nothing ->+       sm+         { toHashMap = HashMap.insertWith f k v h+         , keyPartitions = HashSet.singleton k : ks+         }+     Just keys ->+       sm+         { toHashMap =+             HashSet.foldl' (\h' k' -> HashMap.insertWith f k' v h') h keys+         }++mergeKeysWith+  :: (Hashable k, Eq k)+  => (v -> v -> v)+  -> k+  -> k+  -> ShareMap k v+  -> ShareMap k v+mergeKeysWith f k0 k1 sm | k0 /= k1 =+  let h = toHashMap sm+      ks = keyPartitions sm+   in case break (HashSet.member k0) ks of+     (_before0, []) -> case break (HashSet.member k1) ks of+       (_before1, []) -> sm+       (before1, keys1 : after1) ->+         sm+           { toHashMap = HashMap.insertWith f k0 (h HashMap.! k1) h+           , keyPartitions =+               HashSet.insert k0 keys1 : before1 ++ after1+           }+     (before0, keys0 : after0)+       | HashSet.member k1 keys0 -> sm+       | 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+                 (before1, []) ->+                    HashSet.insert k1 keys0 : before1+                 (before1, keys1 : after1)->+                    HashSet.union keys0 keys1 : before1 ++ after1+          in sm+              { toHashMap =+                  HashSet.foldl' (\h' k' -> HashMap.insert k' v1 h') h (head keys')+              , keyPartitions = keys'+              }+mergeKeysWith _ _ _ sm = sm
+ tests/tasty/ShareMapTests.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}++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+tests =+  localOption (QuickCheckMaxSize 50) $+  localOption (QuickCheckTests 500) $+  testGroup "Data.ShareMap"+    [ testProperty "behaves as ShareMapReference" $ \xs ->+        let m1 :: HashMap Int [Int]+            m1 = Reference.toHashMap $+                  interpretSteps+                    (Reference.insertWith (++))+                    (Reference.mergeKeysWith (++))+                    Reference.empty+                    xs+            m2 = ShareMap.toHashMap $+                  interpretSteps+                    (ShareMap.insertWith (++))+                    (ShareMap.mergeKeysWith (++))+                    ShareMap.empty+                    xs+         in m1 === m2+    ]++-- | The steps to use to generate a ShareMap+data ShareMapStep k v+  = Insert k v+  | MergeKeys k k+  deriving Show++-- | Run a sequence of steps to produce some sharemap+interpretSteps+  :: (k -> v -> a -> a)+  -> (k -> k -> a -> a)+  -> a+  -> [ShareMapStep k v]+  -> a+interpretSteps f g = foldl' $ \a x -> case x of+  Insert k v -> f k v a+  MergeKeys k1 k2 -> g k1 k2 a++instance Arbitrary (ShareMapStep Int [Int]) where+  arbitrary = do+    n <- getSize+    let sz = 8+    resize (min n sz) $ frequency+      [ ( 1+        , Insert+            <$> choose (1, sz)+            <*> (nub <$> listOf (choose (1, sz)))+        )+      , ( 1+        , MergeKeys+            <$> choose (1, sz)+            <*> choose (1, sz)+        )+      ]+  shrink s = case s of+    Insert k v -> Insert k <$> shrink v+    _ -> []
tests/test.hs view
@@ -76,11 +76,10 @@     , testGroup "elim-crash" <$> dirTests elimCmd   "tests/crash"  []             (ExitFailure 1)     , testGroup "proof"      <$> dirTests elimCmd   "tests/proof"     []          ExitSuccess     , testGroup "rankN"      <$> dirTests elimCmd   "tests/rankNTypes" []         ExitSuccess--    , testGroup "horn-pos"   <$> dirTests elimCmd   "tests/horn/pos"  []          ExitSuccess-    , testGroup "horn-neg"   <$> dirTests elimCmd   "tests/horn/neg"  []          (ExitFailure 1)-    , testGroup "horn-pos"   <$> dirTests nativeCmd "tests/horn/pos"  []          ExitSuccess-    , testGroup "horn-neg"   <$> dirTests nativeCmd "tests/horn/neg"  []          (ExitFailure 1)+    , testGroup "horn-pos-el" <$> dirTests elimCmd   "tests/horn/pos"  []          ExitSuccess+    , testGroup "horn-neg-el" <$> dirTests elimCmd   "tests/horn/neg"  []          (ExitFailure 1)+    , testGroup "horn-pos-na" <$> dirTests nativeCmd "tests/horn/pos"  []          ExitSuccess+    , testGroup "horn-neg-na" <$> dirTests nativeCmd "tests/horn/neg"  []          (ExitFailure 1)      -- , testGroup "todo"       <$> dirTests elimCmd   "tests/todo"   []            (ExitFailure 1)     -- , testGroup "todo-crash" <$> dirTests elimCmd   "tests/todo-crash" []        (ExitFailure 2)@@ -112,9 +111,8 @@         assertEqual "" True True       else do         createDirectoryIfMissing True $ takeDirectory log-        bin <- binPath "fixpoint"         withFile log WriteMode $ \h -> do-          let cmd     = testCmd bin dir file+          let cmd     = testCmd "fixpoint" dir file           (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h}           c          <- waitForProcess ph           assertEqual "Wrong exit code" code c@@ -122,9 +120,6 @@     test = dir </> file     log  = let (d,f) = splitFileName file in dir </> d </> ".liquid" </> f <.> "log" -binPath :: FilePath -> IO FilePath-binPath pkgName = (</> pkgName) <$> getBinDir- knownToFail = [] --------------------------------------------------------------------------- type TestCmd = FilePath -> FilePath -> FilePath -> String@@ -338,7 +333,7 @@          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) -> (group</>n,t,s)) soFar
− tests/testParser.hs 
@@ -1,348 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Language.Fixpoint.Types (showFix)-import Language.Fixpoint.Parse-import Test.Tasty-import Test.Tasty.HUnit-import Data.List (intercalate)--main :: IO ()-main = defaultMain $ parserTests--parserTests :: TestTree-parserTests =-  testGroup "Tests"-    [ testSortP-    , testFunAppP-    , testExpr0P-    , testPredP-    , testDeclP-    ]---- ----------------------------------------------------------------------{---sort = '(' sort ')'-     | 'func' funcSort-     | '[' sort ']'-     | bvsort-     | fTyCon-     | tVar--sorts = '[' sortslist ']'--sortslist = sort-          | sort `;` sortslist--funcSort = '(' int `,` sorts ')'--     e.g.(func(1, [int; @(0)]))--bvsort = '(' 'BitVec' 'Size32' ')'-       | '(' 'BitVec' 'Size64' ')'--fTyCon = 'int' | 'Integer' | 'Int' | 'real' | 'num' | 'Str'-       | SYMBOL--SYMBOL = upper case char or _, followed by many of '%' '#' '$' '\'--tVar = '@' varSort-     | LOWERID--varSort = '(' INT ')'--}--testSortP :: TestTree-testSortP =-  testGroup "SortP"-    [ testCase "FAbs" $-        show (doParse' sortP "test" "(func(1, [int; @(0)]))") @?= "FAbs 0 (FFunc FInt (FVar 0))"--    , testCase "(FAbs)" $-        show (doParse' sortP "test" "((func(1, [int; @(0)])))") @?= "FAbs 0 (FFunc FInt (FVar 0))"--    , testCase "FApp FInt" $-        show (doParse' sortP "test" "[int]") @?=-              "FApp (FTC (TC \"[]\" (dummyLoc) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) FInt"--    , testCase "bv32" $-        show (doParse' sortP "test" "BitVec Size32") @?=-              "FApp (FTC (TC \"BitVec\" defined from: \"test\" (line 1, column 1) to: \"test\" (line 1, column 8) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) (FTC (TC \"Size32\" defined from: \"test\" (line 1, column 8) to: \"test\" (line 1, column 14) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False})))"--    , testCase "bv64" $-        show (doParse' sortP "test" "BitVec Size64") @?=-              "FApp (FTC (TC \"BitVec\" defined from: \"test\" (line 1, column 1) to: \"test\" (line 1, column 8) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) (FTC (TC \"Size64\" defined from: \"test\" (line 1, column 8) to: \"test\" (line 1, column 14) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False})))"--    , testCase "FInt int" $-        show (doParse' sortP "test" "int") @?= "FInt"--    , testCase "FInt Integer" $-        show (doParse' sortP "test" "Integer") @?= "FInt"--    , testCase "FInt Int" $-        show (doParse' sortP "test" "Int") @?= "FInt"--    , testCase "FReal real" $-        show (doParse' sortP "test" "real") @?= "FReal"--    , testCase "FNum num" $-        show (doParse' sortP "test" "num") @?= "FNum"--    , testCase "FStr" $-        show (doParse' sortP "test" "Str") @?=-             "FTC (TC \"Str\" (dummyLoc) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = True}))"--    , testCase "SYMBOL" $-        show (doParse' sortP "test" "F#y") @?=-             "FTC (TC \"F#y\" defined from: \"test\" (line 1, column 1) to: \"test\" (line 1, column 4) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))"--    , testCase "FVar 3" $-        show (doParse' sortP "test" "@(3)") @?= "FVar 3"--    , testCase "FObj " $-        show (doParse' sortP "test" "foo") @?= "FObj \"foo\""--    , testCase "FObj " $-        show (doParse' sortP "test" "_foo") @?= "FObj \"_foo\""--    , testCase "Coerce0" $-        show (doParse' predP "test" "v = (coerce (a ~ int) (f x))")-          @?= "PAtom Eq (EVar \"v\") (ECoerc (FObj \"a\") FInt (EApp (EVar \"f\") (EVar \"x\")))"-    ]---- ----------------------------------------------------------------------{---funApp = lit-       | exprFunSpaces-       | expFunSemis-       | expFunCommas-       | simpleApp--lit = 'lit' stringLiteral sort--exprFunSpaces =--exprFunSemis =--exprFunCommas =--simpleApp =--}-testFunAppP :: TestTree-testFunAppP =-  testGroup "FunAppP"-    [ testCase "ECon (litP)" $-        show (doParse' funAppP "test" "lit \"#x00000008\" (BitVec  Size32)") @?=-          "ECon (L \"#x00000008\" (FApp (FTC (TC \"BitVec\" defined from: \"test\" (line 1, column 19) to: \"test\" (line 1, column 27) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False}))) (FTC (TC \"Size32\" defined from: \"test\" (line 1, column 27) to: \"test\" (line 1, column 33) (TCInfo {tc_isNum = False, tc_isReal = False, tc_isString = False})))))"--    , testCase "ECon (exprFunSpacesP)" $-        show (doParse' funAppP "test" "fooBar baz qux") @?= "EApp (EApp (EVar \"fooBar\") (EVar \"baz\")) (EVar \"qux\")"--    , testCase "ECon (exprFunCommasP)" $-        show (doParse' funAppP "test" "fooBar (baz, qux)") @?= "EApp (EVar \"fooBar\") (EApp (EApp (EVar \"(,)\") (EVar \"baz\")) (EVar \"qux\"))"--    , testCase "ECon (exprFunSemisP)" $-        show (doParse' funAppP "test" "fooBar ([baz; qux])") @?= "EApp (EApp (EVar \"fooBar\") (EVar \"baz\")) (EVar \"qux\")"--    , testCase "ECon (simpleAppP)" $-        show (doParse' funAppP "test" "fooBar (baz + 1)") @?= "EApp (EVar \"fooBar\") (EBin Plus (EVar \"baz\") (ECon (I 1)))"-    ]---- ----------------------------------------------------------------------{--expr0 = fastIf-      | symconst-      | constant-      | '_|_'-      | lam-      | '(' expr ')'-      | '(' exprCast ')'-      | symChars---}-testExpr0P :: TestTree-testExpr0P =-  testGroup "expr0P"-    [ testCase "EIte" $-        show (doParse' expr0P "test" "if true then x else y") @?= "EIte (PAnd []) (EVar \"x\") (EVar \"y\")"--    , testCase "ESym SL" $-        show (doParse' expr0P "test" "\"foo\" ") @?= "ESym (SL \"foo\")"--    , testCase "ECon R" $-        show (doParse' expr0P "test" "0.0") @?= "ECon (R 0.0)"--    , testCase "ECon I" $-        show (doParse' expr0P "test" "0") @?= "ECon (I 0)"--    , testCase "ECon I" $-        show (doParse' expr0P "test" "0") @?= "ECon (I 0)"--    , testCase "EBot / POr []" $-        show (doParse' expr0P "test" "_|_") @?= "POr []" -- pattern for "EBot"--    , testCase "ELam" $-        show (doParse' expr0P "test" "\\ foo : Int -> true") @?= "ELam (\"foo\",FInt) (PAnd [])"--    , testCase "Expr" $-        show (doParse' expr0P "test" "(1)") @?= "ECon (I 1)"--    , testCase "ECst dcolon" $-        show (doParse' expr0P "test" "(1 :: Int)") @?= "ECst (ECon (I 1)) FInt"--    , testCase "ECst colon" $-        show (doParse' expr0P "test" "(1 : Int)") @?= "ECst (ECon (I 1)) FInt"--    , testCase "charsExpr EVar" $-        show (doParse' expr0P "test" "foo") @?= "EVar \"foo\""--    , testCase "charsExpr ECon" $-        show (doParse' expr0P "test" "1") @?= "ECon (I 1)"-    ]---- ----------------------------------------------------------------------{---pred = expressionParse (prefixOp++infixOp) pred0--prefixOp = '~' | 'not'--infixOp  = '&&' | '||' | '=>' | '==>' | '<=>'---- terms are pred0-pred0 = 'true' | 'false'-      | '??'-      | kvarPred-      | fastIfP-      | predr-      | '(' pred ')'-      | '?' expr-      | funApp-      | symbol-      | '&&' preds-      | '||' preds--kvarPred = kvar substs--kvar = '$' symbol--substs = {- empty -}-       | subst substs--subst = '[' symbol ':=' expr ']'--preds = '[' predslist ']'--predslist = pred-          | pred `;` predslist--fastIf = 'if' pred 'then' pred 'else' pred--predr = expr brel expr--brelP = '==' | '=' | '~~' | '!=' | '/=' | '!~' | '<' | '<=' | '>' | '>='---}--testPredP :: TestTree-testPredP =-  testGroup "predP"-    [ testCase "PTrue" $-        show (doParse' predP "test" "true") @?= "PAnd []" -- pattern for PTrue--    , testCase "PFalse" $-        show (doParse' predP "test" "false") @?= "POr []" -- pattern for PFalse--   --     , testCase "PGrad / ??" $-   --       show (doParse' predP "test" "??") @?= "PGrad $\"\\\"test\\\" (line 1, column 3)\"  (PAnd [])"-   --   "PGrad $\"\\\"test\\\" (line 1, column 3)\"  (GradInfo {gsrc = SS {sp_start = \"test\" (line 1, column 3), sp_stop = \"test\" (line 1, column 3)}, gused = Nothing}) (PAnd [])"--    , testCase "kvarPred empty" $-        show (doParse' predP "test" "$foo") @?= "PKVar $\"foo\" "--    , testCase "kvarPred one" $-        show (doParse' predP "test" "$foo  [x := 1]") @?= "PKVar $\"foo\" [x:=1]"--    , testCase "kvarPred two" $-        show (doParse' predP "test" "$foo  [x := 1] [ y := true ]") @?= "PKVar $\"foo\" [x:=1][y:=true]"--    , testCase "fastIf" $-        show (doParse' predP "test" "if true then true else false" ) @?=-          -- note conversion-          "PAnd [PImp (PAnd []) (PAnd []),PImp (PNot (PAnd [])) (POr [])]"--    , testCase "brel" $-        show (doParse' predP "test" "1 == 2") @?= "PAtom Eq (ECon (I 1)) (ECon (I 2))"--    , testCase "parens pred" $-        show (doParse' predP "test" "((1 == 2))") @?= "PAtom Eq (ECon (I 1)) (ECon (I 2))"--    , testCase "? expr" $-        show (doParse' predP "test" "? (1+2)") @?= "EBin Plus (ECon (I 1)) (ECon (I 2))"--    , testCase "funApp 1" $-        show (doParse' predP "test" "f a b") @?= "EApp (EApp (EVar \"f\") (EVar \"a\")) (EVar \"b\")"--    , testCase "funApp 2" $-        show (doParse' predP "test" "f (a, b)") @?= "EApp (EVar \"f\") (EApp (EApp (EVar \"(,)\") (EVar \"a\")) (EVar \"b\"))"--    , testCase "funApp 3" $-        show (doParse' predP "test" "f ([a; b])") @?= "EApp (EApp (EVar \"f\") (EVar \"a\")) (EVar \"b\")"--    , testCase "symbol" $-        show (doParse' predP "test" "f") @?= "EVar \"f\""--    , testCase "&& 0" $-        show (doParse' predP "test" "&& []") @?= "PAnd []"--    , testCase "&& 1" $-        show (doParse' predP "test" "&& [x]") @?= "PAnd [EVar \"x\"]"--    , testCase "&& 2" $-        show (doParse' predP "test" "&& [x;y]") @?= "PAnd [EVar \"x\",EVar \"y\"]"--    , testCase "|| 0" $-        show (doParse' predP "test" "|| []") @?= "POr []"--    , testCase "|| 1" $-        show (doParse' predP "test" "|| [x]") @?= "POr [EVar \"x\"]"--    , testCase "|| 2" $-        show (doParse' predP "test" "|| [x;y]") @?= "POr [EVar \"x\",EVar \"y\"]"-    ]---{---data Vec 1 = [-    Nil {}-  | Cons { vHead : @(0), vTail : Vec @(0)}-  ]---}--testDeclP :: TestTree-testDeclP = testGroup "dataDeclP"-  [ mkT "fld0"  dataFieldP fld0-  , mkT "fld1"  dataFieldP fld1-  , mkT "fld2"  dataFieldP fld2-  , mkT "ctor0" dataCtorP  ctor0-  , mkT "ctor1" dataCtorP  ctor1-  , mkT "decl0" dataDeclP decl0-  ]-  where-    mkT name p t = testCase name $ showFix (doParse' p "test" t) @?= t-    fld0    = "vHead : int"-    fld1    = "vHead : @(0)"-    fld2    = "vTail : (Vec @(0))"-    ctor0   = "nil {}"-    ctor1   = "cons {vHead : @(0), vTail : (Vec @(0))}"-    decl0   = intercalate "\n"-                [ "Vec 1 = ["-                , "  | nil {}"-                , "  | cons {vHead : @(0), vTail : Vec}"-                , "]"-                ]
+ tests/todo-crash/wl01.fq view
@@ -0,0 +1,39 @@+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]}
+ tests/todo/LH1090.fq view
@@ -0,0 +1,17 @@+// 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 []+
+ tests/todo/T1371-short.fq view
@@ -0,0 +1,78 @@+// 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 : ()
+ tests/todo/ebind-kvar-chain.fq view
@@ -0,0 +1,39 @@+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]}+