packages feed

liquid-fixpoint 0.9.6.3.7 → 8.10.7

raw patch · 277 files changed

+15321/−14063 lines, 277 filesdep +cmdargsdep +paralleldep −gitrevdep −optparse-applicativedep −smtlib-backendsdep ~bytestringdep ~megaparsecdep ~rest-rewrite

Dependencies added: cmdargs, parallel

Dependencies removed: gitrev, optparse-applicative, smtlib-backends, smtlib-backends-process, smtlib-backends-z3, tagged, vector

Dependency ranges changed: bytestring, megaparsec, rest-rewrite, tasty, tasty-hunit

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
@@ -2,146 +2,28 @@  ## NEXT -## 0.9.6.3.7 (2026-06-04)--- Migrate from cmdargs to base:System.Console.GetOpt-  [#842](https://github.com/ucsd-progsys/liquid-fixpoint/pull/842)-  [#843](https://github.com/ucsd-progsys/liquid-fixpoint/pull/843)-  [#844](https://github.com/ucsd-progsys/liquid-fixpoint/pull/844)--## 0.9.6.3.6 (2026-05-06)--- Drop dependency on lens-family [#841](http://github.com/ucsd-progsys/liquid-fixpoint/pull/841)-- Add sort-compatibility check for measure application in PLE [#840](https://github.com/ucsd-progsys/liquid-fixpoint/pull/840)-- Eagerly expand the body of eta-expanded terms [#838](https://github.com/ucsd-progsys/liquid-fixpoint/pull/838)-- Add polymorphic kvar type variable substitution [#837](https://github.com/ucsd-progsys/liquid-fixpoint/pull/837)-- Show wf constraints in prettified fixpoint queries [#836](https://github.com/ucsd-progsys/liquid-fixpoint/pull/836)-- Unapply solutions in fqout files for readability [#835](https://github.com/ucsd-progsys/liquid-fixpoint/pull/835)-- Wildcard literals in qualifiers in horn constraints. [#834](https://github.com/ucsd-progsys/liquid-fixpoint/pull/834)-- Produce a fqout file before PLE [#835](https://github.com/ucsd-progsys/liquid-fixpoint/pull/835)-- Add `--save-dir` flag to specify output directory for generated files [#832](https://github.com/ucsd-progsys/liquid-fixpoint/pull/832)-- Add `--save-bfq-on-error` flag to collect .bfq files on verification failure [#831](https://github.com/ucsd-progsys/liquid-fixpoint/pull/831)-- Escape SMT string literals [#828](https://github.com/ucsd-progsys/liquid-fixpoint/pull/828)-- Add `cut` support to Horn query parser [#827](https://github.com/ucsd-progsys/liquid-fixpoint/pull/827)-- Fix name captures in substitution of PExist and PAll [#826](https://github.com/ucsd-progsys/liquid-fixpoint/pull/826)-- Don't require a space after the comment start [#825](https://github.com/ucsd-progsys/liquid-fixpoint/pull/825)-- Add support for fractional literals [#822](https://github.com/ucsd-progsys/liquid-fixpoint/pull/822) [#824](https://github.com/ucsd-progsys/liquid-fixpoint/pull/824)-- Generalize expressions and substitutions over binding types [#763](https://github.com/ucsd-progsys/liquid-fixpoint/pull/763)--## 0.9.6.3.5 (2026-01-14)--- Implement `--sortedsolution` to keep elaborated sorts in fqout/solution [#821](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/821)-- Retire old parser for horn queries [#820](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/820)-- Stop the parser from simplifying expressions during parsing [#819](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/819)-- Add `--explicitKvars` option and generalize horn syntax to accept expressions for kvars arguments [#818](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/818)-- Provide more comments in the SMT queries to relate them to the source code [#814](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/814)-- Remove `--no-lazy-ple` [#813](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/813)-- Allow PLE to unfold in kvar solutions  [#811](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/811)-- Remove redundant question marks from expression [#807](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/807)-- Remove distinction of predicates and expressions in the parser [#805](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/805)-- Shrink kvar solutions [#799](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/799) [#809](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/809) [#821](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/821)-- Disable the progress bar when not on a terminal [#798](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/798)-- Retire existential binds [#797](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/797)-- Provide stack traces for more crashes [#794](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/794)-- Support string operators [#793](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/793)-- Apply kvar solutions to constraints before PLE [#792](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/792)-- Retire implementation of gradual refinement types [#789](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/789)-- Retire old PLE variations [#788](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/788)-- Add set cardinality support when using cvc5 [#774](https:://github.com/ucsd-progsys/liquid-fixpoint/pull/774)-- Have `--scrape` consider global constants and ADTs [#772](https://github.com/ucsd-progsys/liquid-fixpoint/pull/772)-- Shorten flags of a few flags and add git-version [#762](https://github.com/ucsd-progsys/liquid-fixpoint/pull/762)-- Add support/conversions for Bitv8 and Bitv16 [#759](https://github.com/ucsd-progsys/liquid-fixpoint/pull/759)-- Support the finite field theory of CVC5 [#755](https://github.com/ucsd-progsys/liquid-fixpoint/pull/755)-- Fix SMT crashes on reflected functions on polymorphic data types [#753](https://github.com/ucsd-progsys/liquid-fixpoint/pull/753)-- Allow function names to start with prefix mod [#751](https://github.com/ucsd-progsys/liquid-fixpoint/pull/751)-- Implement let bindings for Horn queries [#748](https://github.com/ucsd-progsys/liquid-fixpoint/pull/748)-- Fix elaboration of `define_fun` declarations [#747](https://github.com/ucsd-progsys/liquid-fixpoint/pull/747) [#749](https://github.com/ucsd-progsys/liquid-fixpoint/pull/749)--## 0.9.6.3.3 (2025-03-22)--- Add support for GHC HEAD (9.13) [#745](https://github.com/ucsd-progsys/liquid-fixpoint/pull/745).-- Expose SMTLIB define-fun to users of liquid-fixpoint [#744](https://github.com/ucsd-progsys/liquid-fixpoint/pull/744).-- Check that expressions in refinements are Bool-sorted [#743](https://github.com/ucsd-progsys/liquid-fixpoint/pull/743).-- Fix crashes when a datatype is declared with a `Map_t` field [#738](https://github.com/ucsd-progsys/liquid-fixpoint/issues/738).-- Simplify expressions in fqout files [#741](https://github.com/ucsd-progsys/liquid-fixpoint/pull/741).--## 0.9.6.3.2 (2025-03-06)--- Expose relatedSymbols from EnvironmentReduction. Needed for improving error-  messages in LH-  [#2346](https://github.com/ucsd-progsys/liquidhaskell/issues/2346).-- Support extensionality in PLE [#704](https://github.com/ucsd-progsys/liquid-fixpoint/pull/704)-- Add a new flag `--etabeta` to reason with lambdas in PLE [#705](https://github.com/ucsd-progsys/liquid-fixpoint/pull/705)-- Add support for reflected lambdas in PLE [#725](https://github.com/ucsd-progsys/liquid-fixpoint/pull/725)-- Implement Bags and Maps reasoning with Arrays [#703](https://github.com/ucsd-progsys/liquid-fixpoint/pull/703)-- Support conditional elaboration of theories for cvc5 [#734](https://github.com/ucsd-progsys/liquid-fixpoint/pull/734)-- Generate smt2 files only when using `--save` [#712](https://github.com/ucsd-progsys/liquid-fixpoint/pull/712)-- Parameterize Expr and Reft by the variable type [#708](https://github.com/ucsd-progsys/liquid-fixpoint/pull/721)-- Preserve location of operators in the parser [#721](https://github.com/ucsd-progsys/liquid-fixpoint/pull/721)-- Optimize elaboration [#736](https://github.com/ucsd-progsys/liquid-fixpoint/pull/736)--## 0.9.6.3.1 (2024-08-21)--- Added support for ghc-9.10.1-- Use `;` for comments in SMTParse (as done in SMTLIB) [#700](https://github.com/ucsd-progsys/liquid-fixpoint/pull/700).-- Extend SMTParser to support lits e.g. for bitvec [#698](https://github.com/ucsd-progsys/liquid-fixpoint/pull/698).-- refactor `Set->Array` elaboration [#696](https://github.com/ucsd-progsys/liquid-fixpoint/pull/696).-- Fixed the polymorphism-related crash caused by a restrictive Set theory encoding [#688](https://github.com/ucsd-progsys/liquid-fixpoint/pull/688).-- Do not constant-fold div by zero [#686](https://github.com/ucsd-progsys/liquid-fixpoint/issue/686).-- Copy over the HOF configuraration options in hornFInfo [#684](https://github.com/ucsd-progsys/liquid-fixpoint/pull/684).-- Use SMTLIB style serialization/deserialization for Horn queries [#683](https://github.com/ucsd-progsys/liquid-fixpoint/pull/683).-- Print SMT preamble to the logfile when constructing context [#681](https://github.com/ucsd-progsys/liquid-fixpoint/pull/681).-- Allow reading/saving horn queries from/to JSON [#680](https://github.com/ucsd-progsys/liquid-fixpoint/pull/680).-- Extend parser to allow boolean function arguments [#678](https://github.com/ucsd-progsys/liquid-fixpoint/pull/678).--## 0.9.6.3 (2024-01-29)--- For now we stopped folding constants that contain NaN [#670](https://github.com/ucsd-progsys/liquid-fixpoint/pull/670)--## 0.9.4.7--- Support GHC 9.6 tuples with `--extensionality` [#666](https://github.com/ucsd-progsys/liquid-fixpoint/issues/641) [#667](https://github.com/ucsd-progsys/liquid-fixpoint/issues/641)--## 0.9.2.5--- Adopt smtlib-backends for interactions with the SMT solvers [#641](https://github.com/ucsd-progsys/liquid-fixpoint/issues/641)--## 0.9.0.2--- Simplified the equalities dumped by PLE [#569](https://github.com/ucsd-progsys/liquid-fixpoint/issues/569) [#605](https://github.com/ucsd-progsys/liquid-fixpoint/issues/605)-- Add PLE implementation based on interpreting expressions [#502](https://github.com/ucsd-progsys/liquid-fixpoint/pull/502)--## 0.8.10.2--- Dump equalities discovered by PLE [#491](https://github.com/ucsd-progsys/liquid-fixpoint/pull/491) [#569](https://github.com/ucsd-progsys/liquid-fixpoint/issues/569)-- Dump prettified version of constraints [#473](https://github.com/ucsd-progsys/liquid-fixpoint/pull/473)-- Constraints now indicate the source code location that originated them [#471](https://github.com/ucsd-progsys/liquid-fixpoint/pull/471)-- Add support for term rewriting to PLE [#428](https://github.com/ucsd-progsys/liquid-fixpoint/pull/428)--## 0.8.6.4- - Fix bugs in PLE-- Move to GHC 8.6.4+- Move to GHC 8.6.4  - Add `fuel` parameter to debug unfolding in PLE -## 0.8.0.1+## 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+- 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+- 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+- Use `higherorder` flag to allow higher order binders into the environment   ## 0.2.2.0
README.md view
@@ -1,35 +1,25 @@-Liquid Fixpoint+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) ===============  -[![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)-[![hlint](https://github.com/ucsd-progsys/liquid-fixpoint/actions/workflows/hlint.yml/badge.svg)](https://github.com/ucsd-progsys/liquid-fixpoint/actions/workflows/hlint.yml)-[![cabal](https://github.com/ucsd-progsys/liquid-fixpoint/actions/workflows/cabal.yml/badge.svg)](https://github.com/ucsd-progsys/liquid-fixpoint/actions/workflows/cabal.yml)-[![stack](https://github.com/ucsd-progsys/liquid-fixpoint/actions/workflows/stack.yml/badge.svg)](https://github.com/ucsd-progsys/liquid-fixpoint/actions/workflows/stack.yml)  + 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) -Algorithms implemented in liquid-fixpoint: -+ [FUSION](https://ranjitjhala.github.io/static/local_refinement_typing.pdf) Local refinement typing-+ [PLE](https://ranjitjhala.github.io/static/refinement_reflection.pdf) Refinement Reflection: Complete Verification with SMT-+ [REST](https://drops.dagstuhl.de/entities/document/10.4230/DARTS.8.2.12) REST: Integrating Term Rewriting with Program Verification-- Requirements ------------  In addition to the .cabal dependencies you require an SMTLIB2 compatible solver binary: -- [Z3](https://github.com/Z3Prover/z3)-- [CVC4](https://cvc4.github.io/)-- [CVC5](https://cvc5.github.io/)+- [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@@ -38,51 +28,44 @@ How To Build and Install ------------------------ ++Simply do:+ ``` $ git clone https://github.com/ucsd-progsys/liquid-fixpoint.git $ cd liquid-fixpoint-$ stack install # alternatively, use `cabal install`.+$ stack install ``` -Test with+or (`cabal` instead of `stack` if you prefer.) -```-$ stack test-``` -Run with--```-$ stack exec fixpoint -- tests/pos/adt.fq-```- Using SMTLIB-based SMT Solvers ------------------------------  You can use one of several SMTLIB2 compliant solvers, by: -    fixpoint --solver=z3 path/to/file.hs+    fixpoint --smtsolver=z3 path/to/file.hs  Currently, we support      * Z3     * CVC4-    * CVC5     * MathSat -"Horn" Format+"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/neg/ple_list03.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)+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)@@ -151,26 +134,26 @@ Use `--stdin` to read files from `stdin`  ```-$ more tests/horn/pos/test01.smt2 | fixpoint --stdin+$ more tests/horn/pos/test01.smt | fixpoint --stdin -Liquid-Fixpoint Copyright 2009-25 Regents of the University of California.+Liquid-Fixpoint Copyright 2013-15 Regents of the University of California. All Rights Reserved. -Working 166% [===============================================================]-Safe ( 2  constraints checked)+Working 175% [==================================================================================================================]+Safe ( 3  constraints checked) ```  Use `-q` to disable all output (banner, progress bar etc.)  ```-$ more tests/horn/pos/test01.smt2 | fixpoint -q --stdin+$ 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-{"contents":{"numIter":3,"numCstr":3,"numChck":3,"numBrkt":3,"numVald":3},"tag":"Safe"}+"{\"result\":\"safe\"}" ```  @@ -234,34 +217,30 @@   Then a single `IBindEnv` should only mention _at most_   one of `1` or `12`. -* [NOTE:TREE-LIKE] There is also a "tree-shape" property required by PLE:--```-  forall constraints c, c'.-    if i in c and i in c' then-      forall 0 <= j < i, j in c and j in c'-```+* 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 form+  The important bit is that a `KVar` i.e. terms of the formalized  ```-    $k1[@a:=b;a2:=b2][x1:=y1][x2:=y2]...[xn:=yn]+     $k1[x1:=y1][x2:=y2]...[xn:=yn] ``` -  that is represented in the `Expr` type as+  That is represented in the `Expr` type as  ```-  | PKVar  KVar TyVarSubst Subst+  | 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 @@ -283,43 +262,16 @@    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`. -### KVar occurrences--* Each `KVar` that appears in any binding or constraint must have exactly one-  associated wf constraint.--* Each `KVar` that appears in any binding or constraint must have an-  accompanying substitution whose domain has the same symbols as the environment-  of the corresponding wf constraint plus the symbol of its refinement type.--For example, if the wf constraint is-```-    x:int, y: int |- {v:int | $k_##42 }-```--any occurrence of `$k_##42` must be of the form--```-    $k_##42 [x:=e1][y:=e2][v:=e3]-```--Additionally the `KVar` could have a substitution of type variables if it appears-in the return type of a type application (e.g. `f @b` with-`f : forall a. {v1:[a] | $k_##42[v:=v1]}`).--```-  f @b : {v1:[b] | $k_##42[@a:=b][v:=v1] }-```- ### Global vs. Distinct Literals  ```      , gLits    :: !(SEnv Sort)               -- ^ Global Constant symbols-     , dLits    :: !(SEnv Sort)+     , dLits    :: !(SEnv Sort)        ```  The _global_ literals `gLits` are symbols that@@ -365,10 +317,15 @@  > 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: `int`, `bool` and "other". The-`FObj` sort was introduced to represent essentially _all_+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_@@ -385,27 +342,17 @@ > Does that then make FTC types that the SMT solver does > know about (bools, ints, lists, sets, etc.)? -The SMT solvers we currently use know about following sorts:--* `bool`-* `int`-* `real`-* `string`-* `array` (aka `map`)-* `bitvector`-* `set` and `bag` (in Z3, they are both also represented internally as `array`s)-* `finitefield` (CVC5 only)--_All_ other types are _currently_ represented as plain-`Int` inside the SMT solver. However, we _will be_ changing this+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+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+## Qualifier Patterns   ```haskell λ> doParse' (qualParamP sortP) "" "z as (mon . $1) : int"
+ TODO.md view
@@ -0,0 +1,2 @@+# TODO+
bin/Fixpoint.hs view
@@ -1,12 +1,12 @@  import           Language.Fixpoint.Solver        (solveFQ) import           Language.Fixpoint.Horn.Solve    (solveHorn)-import qualified Language.Fixpoint.Misc         as Misc-import qualified Language.Fixpoint.Types        as F-import qualified Language.Fixpoint.Types.Config as F-import qualified Language.Fixpoint.Utils.Files  as F+import qualified Language.Fixpoint.Misc         as Misc +import qualified Language.Fixpoint.Types        as F +import qualified Language.Fixpoint.Types.Config as F +import qualified Language.Fixpoint.Utils.Files  as F  import           System.Exit-import qualified Control.Exception              as Ex+import qualified Control.Exception              as Ex   main :: IO () main = do@@ -18,17 +18,13 @@ --------------------------------------------------------------------------- solveQuery :: F.Config -> IO ExitCode solveQuery cfg     = solver cfg `Ex.catch` errorExit-  where-    solver-      | isHorn cfg = solveHorn-      | otherwise  = solveFQ+  where +    solver     +      | isHorn cfg = solveHorn +      | otherwise  = solveFQ  -isHorn :: F.Config -> Bool-isHorn cfg = F.isExtFile F.Smt2 file-          || F.isExtFile F.Json file-          || F.stdin cfg-  where-    file = F.srcFile cfg+isHorn :: F.Config -> Bool +isHorn cfg = F.isExtFile F.Smt2 (F.srcFile cfg) || F.stdin cfg   errorExit :: F.Error -> IO ExitCode errorExit e = do
+ 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.9.6.3.7+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@@ -16,48 +16,34 @@   In addition to the .cabal dependencies you require   .   * A Z3 (<http://z3.codeplex.com>) or CVC4 (<http://cvc4.cs.nyu.edu>) binary.-category:           Language-homepage:           https://github.com/ucsd-progsys/liquid-fixpoint#readme-bug-reports:        https://github.com/ucsd-progsys/liquid-fixpoint/issues-author:             Ranjit Jhala, Niki Vazou, Eric Seidel-maintainer:         jhala@cs.ucsd.edu-copyright:          2010-17 Ranjit Jhala, University of California, San Diego. license:            BSD-3-Clause license-file:       LICENSE+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, GHC == 8.10.7+category:           Language+homepage:           https://github.com/ucsd-progsys/liquid-fixpoint build-type:         Simple-tested-with:        GHC == 9.14.1, GHC == 9.12.2, GHC == 9.10.1, GHC == 9.8.2 extra-source-files: tests/neg/*.fq                     tests/pos/*.fq                     unix/Language/Fixpoint/Utils/*.hs                     win/Language/Fixpoint/Utils/*.hs                     tests/logs/cur/pin                     Makefile-extra-doc-files:    CHANGES.md-                    README.md -common warnings-  ghc-options:-    -Wall- source-repository head-  type: git-  location: https://github.com/ucsd-progsys/liquid-fixpoint--flag link-z3-as-a-library-  description: link z3 as a library for faster interactions with the SMT solver-  manual: True-  default: False+  type:     git+  location: https://github.com/ucsd-progsys/liquid-fixpoint/  flag devel+  default:     False+  manual:      True   description: turn on stricter error reporting for development-  manual: True-  default: False  library-  import: warnings+  autogen-modules:  Paths_liquid_fixpoint   exposed-modules:  Data.ShareMap-                    Control.Exception.Compat-                    Language.Fixpoint.Conditional.Z3                     Language.Fixpoint.Defunctionalize                     Language.Fixpoint.Graph                     Language.Fixpoint.Graph.Deps@@ -65,30 +51,29 @@                     Language.Fixpoint.Graph.Partition                     Language.Fixpoint.Graph.Reducible                     Language.Fixpoint.Graph.Types-                    Language.Fixpoint.Horn.Info                     Language.Fixpoint.Horn.Parse                     Language.Fixpoint.Horn.Solve-                    Language.Fixpoint.Horn.Transformations                     Language.Fixpoint.Horn.Types+                    Language.Fixpoint.Horn.Transformations+                    Language.Fixpoint.Horn.Info                     Language.Fixpoint.Minimize                     Language.Fixpoint.Misc                     Language.Fixpoint.Parse+                    Language.Fixpoint.Smt.Bitvector                     Language.Fixpoint.Smt.Interface                     Language.Fixpoint.Smt.Serialize                     Language.Fixpoint.Smt.Theories                     Language.Fixpoint.Smt.Types                     Language.Fixpoint.Solver-                    Language.Fixpoint.Solver.Common                     Language.Fixpoint.Solver.Eliminate                     Language.Fixpoint.Solver.EnvironmentReduction-                    Language.Fixpoint.Solver.Extensionality-                    Language.Fixpoint.Solver.Interpreter-                    Language.Fixpoint.Solver.Monad+                    Language.Fixpoint.Solver.GradualSolution+                    Language.Fixpoint.Solver.Instantiate                     Language.Fixpoint.Solver.PLE-                    Language.Fixpoint.Solver.Prettify+                    Language.Fixpoint.Solver.Monad                     Language.Fixpoint.Solver.Rewrite+                    Language.Fixpoint.Solver.Prettify                     Language.Fixpoint.Solver.Sanitize-                    Language.Fixpoint.Solver.Simplify                     Language.Fixpoint.Solver.Solution                     Language.Fixpoint.Solver.Solve                     Language.Fixpoint.Solver.Stats@@ -96,15 +81,15 @@                     Language.Fixpoint.Solver.UniqifyBinds                     Language.Fixpoint.Solver.UniqifyKVars                     Language.Fixpoint.Solver.Worklist+                    Language.Fixpoint.Solver.Extensionality                     Language.Fixpoint.SortCheck                     Language.Fixpoint.Types-                    Language.Fixpoint.Types.Binders                     Language.Fixpoint.Types.Config                     Language.Fixpoint.Types.Constraints                     Language.Fixpoint.Types.Environments                     Language.Fixpoint.Types.Errors+                    Language.Fixpoint.Types.Graduals                     Language.Fixpoint.Types.Names-                    Language.Fixpoint.Types.SMTPrint                     Language.Fixpoint.Types.PrettyPrint                     Language.Fixpoint.Types.Refinements                     Language.Fixpoint.Types.Solutions@@ -121,139 +106,105 @@                     Language.Fixpoint.Utils.Progress                     Language.Fixpoint.Utils.Statistics                     Language.Fixpoint.Utils.Trie-                    Language.Fixpoint.Verbosity                     Text.PrettyPrint.HughesPJ.Compat   other-modules:    Paths_liquid_fixpoint-  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   src-  ghc-options:      -W -Wno-missing-methods -Wmissing-signatures-  build-depends:    aeson+  build-depends:    base                 >= 4.9.1.0 && < 5                   , ansi-terminal                   , array                   , async                   , attoparsec-                  , base                 >= 4.9.1.0 && < 5                   , binary+                  , store+                  , bytestring                   , boxes-                  , bytestring >= 0.10.2.1                   , cereal+                  , cmdargs                   , containers                   , deepseq                   , directory                   , fgl                   , filepath-                  , gitrev              >= 1.3.1                   , hashable                   , intern-                  , megaparsec           >= 7.0.0 && < 10                   , mtl+                  , parallel                   , parser-combinators+                  , megaparsec           >= 7.0.0 && < 9                   , pretty               >= 1.1.3.1                   , process-                  , rest-rewrite >= 0.3.0-                  , smtlib-backends >= 0.3-                  , smtlib-backends-process >= 0.3                   , stm-                  , store-                  , vector < 0.14                   , syb+                  , syb                   , text                   , transformers                   , unordered-containers-  ghc-options:-    -fwrite-ide-info-    -hiedir=.hie-  if flag(link-z3-as-a-library)-    build-depends: smtlib-backends-z3 >= 0.3-    hs-source-dirs: src-cond/with-z3-  else-    hs-source-dirs: src-cond/without-z3+                  , aeson+                  , rest-rewrite >= 0.1.1+  default-language: Haskell98+  ghc-options:      -W -fno-warn-missing-methods -fwarn-missing-signatures -  if impl(ghc<9.6)-    ghc-options: -Wno-unused-imports-  if impl(ghc>9.8)-    ghc-options: -Wno-x-partial-  if impl(ghc>9.10)-    ghc-options: -Wno-deriving-typeable   if flag(devel)     ghc-options: -Werror+   if !os(windows)     hs-source-dirs: unix     build-depends:  ascii-progress >= 0.3+   if os(windows)     hs-source-dirs: win-  default-language: Haskell98  executable fixpoint-  import: warnings   main-is:          Fixpoint.hs-  other-modules:    Paths_liquid_fixpoint-  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   bin-  ghc-options:      -threaded -W -Wno-missing-methods-  build-depends:    base >= 4.9.1.0 && < 5, liquid-fixpoint, gitrev >= 1.3.1+  build-depends:    base >= 4.9.1.0 && < 5, liquid-fixpoint+  default-language: Haskell98+  ghc-options:      -threaded -W -fno-warn-missing-methods+   if flag(devel)     ghc-options: -Werror-  default-language: Haskell98  test-suite test-  import: warnings   type:             exitcode-stdio-1.0   main-is:          test.hs   other-modules:    Paths_liquid_fixpoint-  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   tests-  ghc-options:      -threaded+  build-tool-depends: liquid-fixpoint:fixpoint   build-depends:    base          >= 4.9.1.0 && < 5                   , containers    >= 0.5                   , directory                   , filepath                   , mtl           >= 2.2.2-                  , optparse-applicative                   , process                   , stm           >= 2.4-                  , tagged-                  , tasty         ^>= 1.5+                  , tasty         >= 0.10                   , tasty-ant-xml+                  , tasty-hunit                   , tasty-hunit   >= 0.9                   , tasty-rerun   >= 1.1.12                   , transformers  >= 0.5+  default-language: Haskell98+  ghc-options:      -threaded+   if flag(devel)     ghc-options: -Werror-  build-tool-depends: liquid-fixpoint:fixpoint-  default-language: Haskell98  test-suite tasty-  import: warnings   type:             exitcode-stdio-1.0   main-is:          Main.hs-  other-modules:    Arbitrary-                    InterpretTests-                    ParserTests+  other-modules:    ParserTests                     ShareMapReference                     ShareMapTests-                    SimplifyInterpreter-                    SimplifyKVarTests-                    SimplifyPLE-                    SimplifyTests-                    UndoANFTests-                    Paths_liquid_fixpoint-  if impl(ghc>=9.12.1)-    hs-source-dirs: tests/tasty/ghc-9.12.1-  else-    hs-source-dirs: tests/tasty/ghc-before-9.12.1-  autogen-modules:  Paths_liquid_fixpoint   hs-source-dirs:   tests/tasty-  ghc-options:      -threaded   build-depends:    base            >= 4.9.1.0 && < 5-                  , containers                   , hashable                   , liquid-fixpoint                   , tasty           >= 0.10-                  , tasty-hunit     >= 0.9                   , tasty-quickcheck-                  , text+                  , tasty-hunit     >= 0.9                   , unordered-containers+  default-language: Haskell98+  ghc-options:      -threaded+   if flag(devel)     ghc-options: -Werror-  default-language: Haskell98
+ 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-cond/with-z3/Language/Fixpoint/Conditional/Z3.hs 
@@ -1,12 +0,0 @@-module Language.Fixpoint.Conditional.Z3 where--import qualified SMTLIB.Backends-import qualified SMTLIB.Backends.Z3 as Z3--makeZ3 :: IO (SMTLIB.Backends.Backend, IO ())-makeZ3 = do-    handle <- Z3.new Z3.defaultConfig-    return (Z3.toBackend handle, Z3.close handle)--builtWithZ3AsALibrary :: Bool-builtWithZ3AsALibrary = True
− src-cond/without-z3/Language/Fixpoint/Conditional/Z3.hs 
@@ -1,7 +0,0 @@-module Language.Fixpoint.Conditional.Z3 where--makeZ3 :: IO a-makeZ3 = error "liquid-fixpoint: Not built with the Z3 backend. Please, enable the cabal flag link-z3-as-a-library."--builtWithZ3AsALibrary :: Bool-builtWithZ3AsALibrary = False
− src/Control/Exception/Compat.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-module Control.Exception.Compat-  ( ExceptionWithContext(..)-  , displayExceptionContext-  , wrapExceptionWithContext-  ) where--#if MIN_VERSION_base(4,20,0)--import Control.Exception (ExceptionWithContext(..))-import Control.Exception.Context (displayExceptionContext)--wrapExceptionWithContext :: ExceptionWithContext a -> ExceptionWithContext a-wrapExceptionWithContext = id--#else--data ExceptionWithContext a = ExceptionWithContext ExceptionContext a--data ExceptionContext = ExceptionContext--displayExceptionContext :: ExceptionContext -> String-displayExceptionContext _ = "Exception context not available in this version of ghc."--wrapExceptionWithContext :: a -> ExceptionWithContext a-wrapExceptionWithContext = ExceptionWithContext ExceptionContext-#endif-
+ 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/Defunctionalize.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE TupleSections        #-}+{-# LANGUAGE PatternGuards        #-} {-# LANGUAGE OverloadedStrings    #-}  --------------------------------------------------------------------------------@@ -16,25 +18,20 @@ --   `EApp` and `ELam` to determine the lambdas and redexes. -------------------------------------------------------------------------------- -module Language.Fixpoint.Defunctionalize+module Language.Fixpoint.Defunctionalize    ( defunctionalize   , Defunc(..)   , defuncAny-  ) where+  ) where   import qualified Data.HashMap.Strict as M import           Data.Hashable-import           Data.Bifunctor (bimap)-import           Control.Monad ((>=>)) import           Control.Monad.State-import           Language.Fixpoint.Misc            (fM, secondM)+import           Language.Fixpoint.Misc            (fM, secondM, mapSnd) import           Language.Fixpoint.Solver.Sanitize (symbolEnv)-import           Language.Fixpoint.Types        hiding (GInfo(..), allowHO, fi)-import qualified Language.Fixpoint.Types           as Types (GInfo(..))+import           Language.Fixpoint.Types        hiding (allowHO) import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.Visitor   (mapMExpr)-- -- import Debug.Trace (trace)  defunctionalize :: (Fixpoint a) => Config -> SInfo a -> SInfo a@@ -57,7 +54,7 @@          >=> mapMExpr (fM normalizeLams)  reBind :: Expr -> DF Expr-reBind (ELam (x, s) e) = (\y -> ELam (y, s) (subst1 e (x, EVar y))) <$> freshSym s+reBind (ELam (x, s) e) = ((\y -> ELam (y, s) (subst1 e (x, EVar y))) <$> freshSym s) reBind e               = return e shiftLam :: Int -> Symbol -> Sort -> Expr -> Expr shiftLam i x t e = ELam (x_i, t) (e `subst1` (x, x_i_t))@@ -65,56 +62,23 @@     x_i          = lamArgSymbol i     x_i_t        = ECst (EVar x_i) t --- | normalize lambda arguments [TODO: example]------ Renames lambda bindings to lamb_arg##i. Each use of a lambda binding--- is surrounded with a cast.+-- normalize lambda arguments [TODO: example]  normalizeLams :: Expr -> Expr-normalizeLams = snd . normalizeLamsFromTo 1+normalizeLams e = snd $ normalizeLamsFromTo 1 e  normalizeLamsFromTo :: Int -> Expr -> (Int, Expr) normalizeLamsFromTo i   = go   where-    go :: Expr -> (Int, Expr)-    go (ELam (y, sy) e) = (i' + 1, shiftLam i' y sy e') where (i', e') = go e+    go (ELam (y, sy) e) = (i + 1, shiftLam i y sy e') where (i, e') = go e                           -- let (i', e') = go e                           --    y'       = lamArgSymbol i'  -- SHIFTLAM                           -- in (i' + 1, ELam (y', sy) (e' `subst1` (y, EVar y')))     go (EApp e1 e2)     = let (i1, e1') = go e1                               (i2, e2') = go e2                           in (max i1 i2, EApp e1' e2')-    go (ECst e s)       = fmap (`ECst` s) (go e)-    go (ELet x e1 e2)   = let (i1, e1') = go e1-                              (i2, e2') = go e2-                          in (max i1 i2, ELet x e1' e2')-    go (EIte e1 e2 e3)  = let (i1, e1') = go e1-                              (i2, e2') = go e2-                              (i3, e3') = go e3-                          in (maximum [i1, i2, i3], EIte e1' e2' e3')-    go (ENeg e)         = fmap ENeg (go e)-    go (EBin op e1 e2)  = let (i1, e1') = go e1-                              (i2, e2') = go e2-                          in (max i1 i2, EBin op e1' e2')-    go (ETApp e s)      = fmap (`ETApp` s) (go e)-    go (ETAbs e s)      = fmap (`ETAbs` s) (go e)-    go (PAnd [])        = (i, PAnd [])-    go (POr [])         = (i, POr  [])-    go (PAnd es)        = bimap maximum PAnd $ unzip $ fmap go es-    go (POr es)         = bimap maximum POr  $ unzip $ fmap go es-    go (PNot e)         = fmap PNot (go e)-    go (PImp e1 e2)     = let (i1, e1') = go e1-                              (i2, e2') = go e2-                          in (max i1 i2, PImp e1' e2')-    go (PIff e1 e2)     = let (i1, e1') = go e1-                              (i2, e2') = go e2-                          in (max i1 i2, PIff e1' e2')-    go (PAtom r e1 e2)  = let (i1, e1') = go e1-                              (i2, e2') = go e2-                          in (max i1 i2, PAtom r e1' e2')-    go (PAll bs e)      = fmap (PAll bs) (go e)-    go (PExist bs e)    = fmap (PExist bs) (go e)-    go (ECoerc s1 s2 e) = fmap (ECoerc s1 s2) (go e)+    go (ECst e s)       = mapSnd (`ECst` s) (go e)+    go (PAll bs e)      = mapSnd (PAll bs) (go e)     go e                = (i, e)  @@ -125,22 +89,22 @@ class Defunc a where   defunc :: a -> DF a -instance (Defunc (c a), TaggedC c a) => Defunc (Types.GInfo c a) where+instance (Defunc (c a), TaggedC c a) => Defunc (GInfo c a) where   defunc fi = do-    cm'    <- defunc $ Types.cm    fi-    ws'    <- defunc $ Types.ws    fi+    cm'    <- defunc $ cm    fi+    ws'    <- defunc $ ws    fi     -- NOPROP setBinds $ mconcat ((senv <$> M.elems (cm fi)) ++ (wenv <$> M.elems (ws fi)))-    gLits' <- defunc $ Types.gLits fi-    dLits' <- defunc $ Types.dLits fi-    bs'    <- defunc $ Types.bs    fi-    ass'   <- defunc $ Types.asserts fi+    gLits' <- defunc $ gLits fi+    dLits' <- defunc $ dLits fi+    bs'    <- defunc $ bs    fi+    ass'   <- defunc $ asserts fi     -- NOPROP quals' <- defunc $ quals fi-    return $ fi { Types.cm      = cm'-                , Types.ws      = ws'-                , Types.gLits   = gLits'-                , Types.dLits   = dLits'-                , Types.bs      = bs'-                , Types.asserts = ass'+    return $ fi { cm      = cm'+                , ws      = ws'+                , gLits   = gLits'+                , dLits   = dLits'+                , bs      = bs'+                , asserts = ass'                 }  instance (Defunc a) => Defunc (Triggered a) where@@ -150,11 +114,16 @@   defunc sc = do crhs' <- defunc $ _crhs sc                  return $ sc {_crhs = crhs'} -instance Defunc (WfC a) where-  defunc wf@WfC{} = do+instance Defunc (WfC a)   where+  defunc wf@(WfC {}) = do     let (x, t, k) = wrft wf     t' <- defunc t     return $ wf { wrft = (x, t', k) }+  defunc wf@(GWfC {}) = do+    let (x, t, k) = wrft wf+    t' <- defunc t+    e' <- defunc $ wexpr wf+    return $ wf { wrft = (x, t', k), wexpr = e' }  instance Defunc SortedReft where   defunc (RR s r) = RR s <$> defunc r@@ -174,7 +143,7 @@ instance Defunc a => Defunc (SEnv a) where   defunc = mapMSEnv defunc -instance Defunc (BindEnv a) where+instance Defunc BindEnv   where   defunc bs = do dfbs <- gets dfBEnv                  let f (i, xs) = if i `memberIBindEnv` dfbs                                        then  (i,) <$> defunc xs@@ -185,7 +154,7 @@     -- the bind does not appear in any contraint,     -- thus unique binders does not perform properly     -- The sort should be defunc, to ensure same sort on double binders-    matchSort (x, RR s r) = (x,) . (`RR` r) <$> defunc s+    matchSort (x, RR s r) = ((x,) . (`RR` r)) <$> defunc s  -- Sort defunctionalization [should be done by elaboration] instance Defunc Sort where@@ -197,7 +166,7 @@ instance (Defunc a, Eq k, Hashable k) => Defunc (M.HashMap k a) where   defunc m = M.fromList <$> mapM (secondM defunc) (M.toList m) -type DF = State DFST+type DF    = State DFST  data DFST = DFST   { dfFresh :: !Int@@ -207,7 +176,7 @@   , dfLams  :: ![Expr]      -- ^ lambda expressions appearing in the expressions   , dfRedex :: ![Expr]      -- ^ redexes appearing in the expressions   , dfBinds :: !(SEnv Sort) -- ^ sorts of new lambda-binders-  } deriving Show+  }  makeDFState :: Config -> SymEnv -> IBindEnv -> DFST makeDFState cfg env ibind = DFST@@ -215,7 +184,7 @@   , dfEnv   = env   , dfBEnv  = ibind   , dfHO    = allowHO cfg  || defunction cfg-  -- INVARIANT: lambdas and redexes are not defunctionalized+  -- INVARIANT: lambads and redexes are not defunctionalized   , dfLams  = []   , dfRedex = []   , dfBinds = mempty@@ -225,7 +194,7 @@ makeInitDFState cfg si   = makeDFState cfg       (symbolEnv cfg si)-      (mconcat ((senv <$> M.elems (Types.cm si)) ++ (wenv <$> M.elems (Types.ws si))))+      (mconcat ((senv <$> M.elems (cm si)) ++ (wenv <$> M.elems (ws si))))  -------------------------------------------------------------------------------- -- | Low level monad manipulation ----------------------------------------------@@ -236,3 +205,8 @@   let x = intSymbol "lambda_fun_" n   modify $ \s -> s {dfFresh = n + 1, dfBinds = insertSEnv x t (dfBinds s)}   return x+++-- | getLams and getRedexes return the (previously seen) lambdas and redexes,+--   after "closing" them by quantifying out free vars corresponding to the+--   fresh binders in `dfBinds`.
src/Language/Fixpoint/Graph/Deps.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections         #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE RecordWildCards       #-}  module Language.Fixpoint.Graph.Deps (@@ -28,6 +29,10 @@  import           Prelude hiding (init) import           Data.Maybe                       (mapMaybe, fromMaybe)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup                   (Semigroup (..))+#endif+ import           Data.Tree (flatten) import           Language.Fixpoint.Misc import           Language.Fixpoint.Utils.Files@@ -55,9 +60,9 @@ -------------------------------------------------------------------------------- slice :: (F.TaggedC c a) => Config -> F.GInfo c a -> F.GInfo c a ---------------------------------------------------------------------------------slice cfg fi-  | noslice cfg-  = fi+slice cfg fi +  | noslice cfg +  = fi    | otherwise   = fi { F.cm = cm'        , F.ws = ws' }@@ -77,7 +82,7 @@     be           = F.bs fi     cm           = F.cm fi -subcKVars :: (F.TaggedC c a) => F.BindEnv a -> c a -> [F.KVar]+subcKVars :: (F.TaggedC c a) => F.BindEnv -> c a -> [F.KVar] subcKVars be c = V.envKVars be c ++ V.rhsKVars c  --------------------------------------------------------------------------------@@ -205,16 +210,12 @@ edgeGraph es = KVGraph [(v, v, vs) | (v, vs) <- groupList es ]  -- need to plumb list of ebinds---- | Compute dependencies between constraints and kvars.------ @(k, c)@ means that constraint @c@ uses kvar @k@ on the LHS.--- @(c, k)@ means that constraint @c@ uses kvar @k@ on the RHS. {-# SCC kvEdges #-} kvEdges :: (F.TaggedC c a) => F.GInfo c a -> [CEdge]-kvEdges fi = selfes ++ concatMap (subcEdges bs) cs+kvEdges fi = selfes ++ concatMap (subcEdges bs) cs ++ concatMap (ebindEdges ebs bs) cs   where     bs     = F.bs fi+    ebs    = F.ebinds fi     cs     = M.elems (F.cm fi)     ks     = fiKVars fi     selfes =  [(Cstr i , Cstr  i) | c <- cs, let i = F.subcId c]@@ -224,7 +225,22 @@ fiKVars :: F.GInfo c a -> [F.KVar] fiKVars = M.keys . F.ws -subcEdges :: (F.TaggedC c a) => F.BindEnv a -> c a -> [CEdge]+ebindEdges :: (F.TaggedC c a) => [F.BindId] -> F.BindEnv -> c a -> [CEdge]+ebindEdges ebs bs c =  [(EBind k, Cstr i ) | k  <- envEbinds xs bs c ]+                    ++ [(Cstr i, EBind k') | k' <- rhsEbinds xs c ]+  where+    i          = F.subcId c+    xs         = fst . flip F.lookupBindEnv bs <$> ebs++envEbinds :: (F.TaggedC c a, Foldable t) =>+             t F.Symbol -> F.BindEnv -> c a -> [F.Symbol]+envEbinds xs be c = [ x | x <- envBinds , x `elem` xs ]+  where envBinds = fst <$> F.clhs be c+rhsEbinds :: (Foldable t, F.TaggedC c a) =>+             t F.Symbol -> c a -> [F.Symbol]+rhsEbinds xs c = [ x | x <- F.syms (F.crhs c) , x `elem` xs ]++subcEdges :: (F.TaggedC c a) => F.BindEnv -> c a -> [CEdge] subcEdges bs c =  [(KVar k, Cstr i ) | k  <- V.envKVars bs c]                ++ [(Cstr i, KVar k') | k' <- V.rhsKVars c ]   where@@ -234,10 +250,10 @@ -- | Eliminated Dependencies -------------------------------------------------------------------------------- {-# SCC elimDeps #-}-elimDeps :: (F.TaggedC c a) => F.GInfo c a -> [CEdge] -> S.HashSet F.KVar -> CDeps-elimDeps si es nonKutVs = graphDeps si es'+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-    es'                 = graphElim es nonKutVs+    es'                 = graphElim es nonKutVs ebs     _msg                = "graphElim: " ++ show (length es')  {- | `graphElim` "eliminates" a kvar k by replacing every "path"@@ -248,8 +264,9 @@            ki ------------> c -}-graphElim :: [CEdge] -> S.HashSet F.KVar -> [CEdge]-graphElim es ks = ikvgEdges $ elimKs (S.map KVar ks)   $ edgesIkvg es+graphElim :: [CEdge] -> S.HashSet F.KVar -> S.HashSet F.Symbol -> [CEdge]+graphElim es ks _ebs = ikvgEdges $ -- elimEs (S.map EBind ebs) $+                                  elimKs (S.map KVar ks)   $ edgesIkvg es   where     elimKs      = flip (S.foldl' elimK)     _elimEs      = flip (S.foldl' elimE)@@ -295,10 +312,8 @@ dCut    v = Deps (S.singleton v) S.empty  ----------------------------------------------------------------------------------- | Compute Dependencies and Cuts------ Computes greedily a set of kvars that make the dependency graph acyclic when--- removed. Also yields the edges of the dependency graph.+-- | Compute Dependencies and Cuts ---------------------------------------------+-------------------------------------------------------------------------------- {-# SCC elimVars #-} elimVars :: (F.TaggedC c a) => Config -> F.GInfo c a -> ([CEdge], Elims F.KVar) --------------------------------------------------------------------------------@@ -352,12 +367,11 @@ -------------------------------------------------------------------------------- type EdgeRank = M.HashMap F.KVar Integer ----------------------------------------------------------------------------------- | Builds a map from KVar to the _smallest_ ConstraintID that KVar appears in LHS of edgeRank :: [CEdge] -> EdgeRank edgeRank es = minimum . (n :) <$> kiM   where-    n       = 1 + maximum [ i | (Cstr i, _)     <- es ] -- number larger than maximum constraint id-    kiM     = group [ (k, i) | (KVar k, Cstr i) <- es ] -- map each `k` to cstrs in which it appears on LHS+    n       = 1 + maximum [ i | (Cstr i, _)     <- es ]+    kiM     = group [ (k, i) | (KVar k, Cstr i) <- es ]  edgeRankCut :: EdgeRank -> Cutter CVertex edgeRankCut km vs = case ks of@@ -500,7 +514,7 @@ -- The returned map tells for each coonstraint writing a kvar -- which constraints are reading the kvar. cSuccM      :: [CEdge] -> CMap [F.SubcId]-cSuccM es    = sortNub . concatMap kRdBy <$> iWrites+cSuccM es    = (sortNub . concatMap kRdBy) <$> iWrites   where     kRdBy k  = M.lookupDefault [] k kReads     iWrites  = group [ (i, k) | (Cstr i, KVar k) <- es ]@@ -552,7 +566,7 @@   }  instance PTable Stats where-  ptable Stats{..}  = DocTable [+  ptable (Stats {..})  = DocTable [       ("# KVars [Cut]"    , pprint stNumKVCuts)     , ("# KVars [NonLin]" , pprint stNumKVNonLin)     , ("# KVars [All]"    , pprint stNumKVTotal)@@ -572,12 +586,13 @@     nlks          = nonLinearKVars si     d             = snd $ elimVars cfg si --- | KVars used more than once in the LHS of some constraint+-------------------------------------------------------------------------------- nonLinearKVars :: (F.TaggedC c a) => F.GInfo c a -> S.HashSet F.KVar+-------------------------------------------------------------------------------- nonLinearKVars fi = S.unions $ nlKVarsC bs <$> cs   where     bs            = F.bs fi     cs            = M.elems (F.cm fi) -nlKVarsC :: (F.TaggedC c a) => F.BindEnv a -> c a -> S.HashSet F.KVar+nlKVarsC :: (F.TaggedC c a) => F.BindEnv -> c a -> S.HashSet F.KVar nlKVarsC bs c = S.fromList [ k |  (k, n) <- V.envKVarsN bs c, n >= 2]
src/Language/Fixpoint/Graph/Indexed.hs view
@@ -4,6 +4,7 @@ --   succ, pred lookup -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-}  module Language.Fixpoint.Graph.Indexed (   -- * (Abstract) Indexed Graphs
src/Language/Fixpoint/Graph/Partition.hs view
@@ -39,9 +39,12 @@ -- import           Data.Function (on) import           Data.Maybe                     (fromMaybe) import           Data.Hashable+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup                 (Semigroup (..))+#endif+ import           Text.PrettyPrint.HughesPJ.Compat import           Data.List (sortBy)-import           Data.Function (on) -- import qualified Data.HashSet              as S  -- import qualified Language.Fixpoint.Solver.Solution    as So@@ -56,7 +59,7 @@ data CPart c a = CPart { pws :: !(M.HashMap F.KVar (F.WfC a))                        , pcm :: !(M.HashMap Integer (c a))                        }-+   instance Semigroup (CPart c a) where   l <> r = CPart { pws = pws l <> pws r                  , pcm = pcm l <> pcm r@@ -65,7 +68,7 @@ instance Monoid (CPart c a) where    mempty      = CPart mempty mempty    mappend     = (<>)-+    -------------------------------------------------------------------------------- -- | Multicore info ------------------------------------------------------------ --------------------------------------------------------------------------------@@ -98,7 +101,7 @@ --   produce the maximum possible number of partitions. Or a MultiCore Info --   to control the partitioning -------------------------------------------------------------------------------partition' :: (F.TaggedC c a)+partition' :: (F.TaggedC c a)             => Maybe MCInfo -> F.GInfo c a -> [F.GInfo c a] ------------------------------------------------------------------------------ partition' mn fi  = case mn of@@ -110,8 +113,8 @@     pbc partF      = partitionByConstraints partF fi  -- | Partition an FInfo into a specific number of partitions of roughly equal--- amounts of work.-partitionN :: MCInfo        -- ^ Describes thresholds and partition amounts+-- amounts of work+partitionN :: MCInfo        -- ^ describes thresholds and partiton amounts            -> F.GInfo c a   -- ^ The originial FInfo            -> [CPart c a]   -- ^ A list of the smallest possible CParts            -> [F.GInfo c a] -- ^ At most N partitions of at least thresh work@@ -131,7 +134,10 @@       sortedParts = sortBy sortPredicate cp       unionFirstTwo (a:b:xs) = (a `mappend` b, xs)       unionFirstTwo _        = errorstar "Partition.partitionN.unionFirstTwo called on bad arguments"-      sortPredicate = flip compare `on` cpartSize+      sortPredicate lhs rhs+         | cpartSize lhs < cpartSize rhs = GT+         | cpartSize lhs > cpartSize rhs = LT+         | otherwise = EQ       insertSorted a []     = [a]       insertSorted a (x:xs) = if sortPredicate a x == LT                               then x : insertSorted a xs@@ -148,7 +154,7 @@  -- | Convert a CPart to an FInfo cpartToFinfo :: F.GInfo c a -> CPart c a -> F.GInfo c a-cpartToFinfo fi p = fi {F.ws = pws p, F.cm = pcm p}+cpartToFinfo fi p = fi {F.ws = pws p, F.cm = pcm p}   -- | Convert an FInfo to a CPart finfoToCpart :: F.GInfo c a -> CPart c a
src/Language/Fixpoint/Graph/Reducible.hs view
@@ -53,12 +53,10 @@ contains t x = x `elem` concatMap T.flatten t  isBackEdge :: [(Node, [Node])] -> Edge -> Bool-isBackEdge t (u,v) = case lookup u t of-  Just xs -> v `elem` xs-  -- REVIEW: Would False work instead of error?-  Nothing -> error "Unable to lookup back edge"-+isBackEdge t (u,v) = v `elem` xs+  where+    (Just xs) = lookup u t -subcEdges' :: (F.TaggedC c a) => (F.KVar -> Node) -> F.BindEnv a -> c a -> [(Node, Node)]+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.kvarsExpr $ F.crhs c]
src/Language/Fixpoint/Graph/Types.hs view
@@ -66,18 +66,20 @@  data CVertex = KVar  !KVar    -- ^ real kvar vertex              | DKVar !KVar    -- ^ dummy to ensure each kvar has a successor+             | EBind !F.Symbol  -- ^ existentially bound "ghost paramter" to solve for              | Cstr  !Integer -- ^ constraint-id which creates a dependency                deriving (Eq, Ord, Show, Generic)  instance PPrint CVertex where   pprintTidy _ (KVar k)  = doubleQuotes $ pprint $ kv k+  pprintTidy _ (EBind s)  = doubleQuotes $ pprint $ s   pprintTidy _ (Cstr i)  = text "id_" <-> pprint i   pprintTidy _ (DKVar k) = pprint k   <-> text "*"   instance Hashable CVertex -newtype KVGraph = KVGraph { kvgEdges :: [(CVertex, CVertex, [CVertex])] }+data KVGraph    = KVGraph { kvgEdges :: [(CVertex, CVertex, [CVertex])] } type CEdge      = (CVertex, CVertex) type Comps a    = [[a]] type KVComps    = Comps CVertex@@ -190,8 +192,8 @@ -- | `SolverInfo` contains all the stuff needed to produce a result, and is the --   the essential ingredient of the state needed by solve_ ---------------------------------------------------------------------------------data SolverInfo a = SI-  { siSol     :: !(F.Sol F.QBind)             -- ^ the initial solution+data SolverInfo a b = SI+  { siSol     :: !(F.Sol b F.QBind)             -- ^ the initial solution   , siQuery   :: !(F.SInfo a)                   -- ^ the whole input query   , siDeps    :: !CDeps                         -- ^ dependencies between constraints/ranks etc.   , siVars    :: !(S.HashSet F.KVar)            -- ^ set of KVars to actually solve for
src/Language/Fixpoint/Horn/Info.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} @@ -5,70 +8,67 @@     hornFInfo   ) where -import           Data.Ord (Down(..), comparing) import qualified Data.HashMap.Strict            as M-import qualified Data.HashSet                   as S import qualified Data.List                      as L import qualified Data.Tuple                     as Tuple+import qualified Data.Maybe                     as Mb+import           Data.Either                    (partitionEithers) import           GHC.Generics                   (Generic) import qualified Language.Fixpoint.Misc         as Misc import qualified Language.Fixpoint.Types        as F import qualified Language.Fixpoint.Types.Config as F import qualified Language.Fixpoint.Horn.Types   as H-import qualified Data.Maybe                     as Mb -hornFInfo :: (F.Fixpoint a, F.PPrint a) => F.Config -> H.Query a -> F.FInfo a+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 ++ scrapeCstr (F.scrape cfg) hCst+  , 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-  , F.hoInfo    = F.cfgHoInfo cfg-  , F.defns     = F.MkDefinedFuns (H.qDefs q)-  , F.kuts      = F.KS (S.fromList (H.qKuts q))   }   where     be0         = F.emptyBindEnv     (be1, kve)  = hornWfs   be0     (H.qVars q)-    (be2, cs) = hornSubCs be1 kve hCst+    (be2, ebs, cs) = hornSubCs be1 kve hCst     hCst           = H.qCstr q --axEnv :: F.Config -> H.Query a -> M.HashMap F.SubcId b -> F.AxiomEnv-axEnv cfg q cs = mempty+axEnv :: F.Config -> H.Query a -> M.HashMap F.SubcId b -> F.AxiomEnv +axEnv cfg q cs = mempty    { F.aenvEqs    = H.qEqns q   , F.aenvSimpl  = H.qMats q-  , F.aenvExpand = if F.rewriteAxioms cfg then True <$ cs else mempty-  }+  , F.aenvExpand = if F.rewriteAxioms cfg then const True <$> cs else mempty+  }   -----------------------------------------------------------------------------------hornSubCs :: F.BindEnv a -> KVEnv a -> H.Cstr a-          -> (F.BindEnv a, M.HashMap F.SubcId (F.SubC a))+hornSubCs :: F.BindEnv -> KVEnv a -> H.Cstr a+          -> (F.BindEnv, [F.BindId], M.HashMap F.SubcId (F.SubC a)) -----------------------------------------------------------------------------------hornSubCs be kve c = (be', M.fromList (F.addIds cs))+hornSubCs be kve c = (be', ebs, M.fromList (F.addIds cs))   where-    (be', cs) = goS kve F.emptyIBindEnv be c-    -- lhs0           = bindSortedReft kve H.dummyBind+    (be', ebs, cs)      = goS kve F.emptyIBindEnv lhs0 be c+    lhs0           = bindSortedReft kve H.dummyBind  -- | @goS@ recursively traverses the NNF constraint to build up a list --   of the vanilla @SubC@ constraints. -goS :: KVEnv a -> F.IBindEnv ->  F.BindEnv a -> H.Cstr a-    -> (F.BindEnv a, [F.SubC a])+goS :: KVEnv a -> F.IBindEnv -> F.SortedReft -> F.BindEnv -> H.Cstr a+    -> (F.BindEnv, [F.BindId], [F.SubC a]) -goS kve env be c = (be', subcs)+goS kve env lhs be c = (be', mEbs, subcs)   where-    (be', subcs) = goS' kve env Nothing be c+    (be', ecs) = goS' kve env lhs be c+    (mEbs, subcs) = partitionEithers ecs -goS' :: KVEnv a -> F.IBindEnv -> Maybe F.SortedReft -> F.BindEnv a -> H.Cstr a-    -> (F.BindEnv a, [F.SubC a])-goS' kve env lhs be (H.Head p l) = (be, [subc])+goS' :: KVEnv a -> F.IBindEnv -> F.SortedReft -> F.BindEnv -> H.Cstr a+    -> (F.BindEnv, [Either F.BindId (F.SubC a)])+goS' kve env lhs be (H.Head p l) = (be, [Right subc])   where-    subc                        = myMkSubC env lhs rhs Nothing [] l+    subc                        = F.mkSubC env lhs rhs Nothing [] l     rhs                         = updSortedReft kve lhs p  goS' kve env lhs be (H.CAnd cs)  = (be', concat subcss)@@ -77,26 +77,23 @@  goS' kve env _   be (H.All b c)  = (be'', subcs)   where-    (be'', subcs)               = goS' kve env' (Just bSR) be' c-    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR (H.bMeta b) be+    (be'', subcs)               = goS' kve env' bSR be' c+    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR be     bSR                         = bindSortedReft kve b     env'                        = F.insertsIBindEnv [bId] env -myMkSubC :: F.IBindEnv -> Maybe F.SortedReft -> F.SortedReft -> Maybe Integer -> F.Tag -> a -> F.SubC a-myMkSubC be lhsMb rhs x y z = F.mkSubC be lhs rhs x y z+goS' kve env _   be (H.Any b c)  = (be'', Left bId : subcs)   where-    lhs = Mb.fromMaybe def lhsMb-    def = F.trueSortedReft (F.sr_sort rhs)+    (be'', subcs)               = goS' kve env' bSR be' c+    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR be+    bSR                         = bindSortedReft kve b+    env'                        = F.insertsIBindEnv [bId] env -bindSortedReft :: KVEnv a -> H.Bind a -> F.SortedReft-bindSortedReft kve (H.Bind x t p _) = F.RR t (F.Reft (x, predExpr kve p))+bindSortedReft :: KVEnv a -> H.Bind -> F.SortedReft+bindSortedReft kve (H.Bind x t p) = F.RR t (F.Reft (x, predExpr kve p)) -updSortedReft :: KVEnv a -> Maybe F.SortedReft -> H.Pred -> F.SortedReft-updSortedReft kve lhs p = F.RR s (F.Reft (v, predExpr kve p))-   where-      (s, v) = case lhs of-                 Just (F.RR ss (F.Reft (vv, _))) -> (ss, vv)-                 Nothing                       -> (F.intSort, F.dummySymbol)+updSortedReft :: KVEnv a -> F.SortedReft -> H.Pred -> F.SortedReft+updSortedReft kve (F.RR s (F.Reft (v, _))) p = F.RR s (F.Reft (v, predExpr kve p))  predExpr :: KVEnv a -> H.Pred -> F.Expr predExpr kve        = go@@ -105,15 +102,15 @@     go (H.Var k ys) = kvApp kve k ys     go (H.PAnd  ps) = F.PAnd (go <$> ps) -kvApp :: KVEnv a -> F.Symbol -> [F.Expr] -> F.Expr-kvApp kve k ys = F.PKVar (F.KV k) M.empty su+kvApp :: KVEnv a -> F.Symbol -> [F.Symbol] -> F.Expr+kvApp kve k ys = F.PKVar (F.KV k) su   where-    su         = F.mkKVarSubst (zip params ys)-    params     = maybe err1 kvParams (M.lookup k kve)+    su         = F.mkSubst (zip params (F.eVar <$> ys))+    params     = Mb.fromMaybe err1 $ kvParams <$> M.lookup k kve     err1       = F.panic ("Unknown Horn variable: " ++ F.showpp k)  -----------------------------------------------------------------------------------hornWfs :: (F.PPrint a) => F.BindEnv a -> [H.Var a] -> (F.BindEnv a, KVEnv a)+hornWfs :: F.BindEnv -> [H.Var a] -> (F.BindEnv, KVEnv a) ---------------------------------------------------------------------------------- hornWfs be vars = (be', kve)   where@@ -121,22 +118,21 @@     (be', is)   = L.mapAccumL kvInfo be vars     kname       = H.hvName . kvVar -kvInfo :: (F.PPrint a) => F.BindEnv a -> H.Var a -> (F.BindEnv a, KVInfo a)-kvInfo be k       = (be', KVInfo k (Misc.fst3 <$> xts) wfc)+kvInfo :: F.BindEnv -> H.Var a -> (F.BindEnv, KVInfo a)+kvInfo be k       = (be', KVInfo k (fst <$> xts) wfc)   where     -- make the WfC-    wfc           = F.WfC wenv wrft (H.hvMeta k)+    wfc           = F.WfC wenv wrft  (H.hvMeta k)     wenv          = F.fromListIBindEnv ids     wrft          = (x, t, F.KV (H.hvName k))     -- add the binders     (be', ids)    = L.mapAccumL insertBE be xts'-    ((x,t,_), xts') = Misc.safeUncons "Horn var with no args" xts+    ((x,t), xts') = Misc.safeUncons "Horn var with no args" xts     -- make the parameters-    xts           = [ (hvarArg k i, t', a) | (t', i) <- zip (H.hvArgs k) [0..] ]-    a             = H.hvMeta k+    xts           = [ (hvarArg k i, t) | (t, i) <- zip (H.hvArgs k) [0..] ] -insertBE :: F.BindEnv a -> (F.Symbol, F.Sort, a) -> (F.BindEnv a, F.BindId)-insertBE be (x, t, a) = Tuple.swap $ F.insertBindEnv x (F.trueSortedReft t) a be+insertBE :: F.BindEnv -> (F.Symbol, F.Sort) -> (F.BindEnv, F.BindId)+insertBE be (x, t) = Tuple.swap $ F.insertBindEnv x (F.trueSortedReft t) be  ---------------------------------------------------------------------------------- -- | Data types and helpers for manipulating information about KVars@@ -154,92 +150,7 @@ kvEnvWfCs kve = M.fromList [ (F.KV k, kvWfC info) | (k, info) <- M.toList kve ]  hvarArg :: H.Var a -> Int -> F.Symbol-hvarArg k i = F.hvarArgSymbol (H.hvName k) i------------------------------------------------------------------------------------ | Automatically scrape qualifiers from all predicates in a constraint----------------------------------------------------------------------------------scrapeCstr :: F.Scrape -> H.Cstr a -> [F.Qualifier]-scrapeCstr F.No _    = []-scrapeCstr m    cstr = Misc.sortNub $ go emptyBindEnv cstr-  where-    go senv (H.Head p _) = scrapePred senv p-    go senv (H.CAnd cs)  = concatMap (go senv) cs-    go senv (H.All b c)  = scrapeBind m senv' b <> go senv' c where senv' = insertBindEnv b senv--scrapeBind :: F.Scrape -> BindEnv -> H.Bind a -> [F.Qualifier]-scrapeBind F.Both senv b = scrapePred senv (H.bPred b)-scrapeBind _      _    _ = []--scrapePred :: BindEnv -> H.Pred -> [F.Qualifier]-scrapePred _    (H.Var _ _) = []-scrapePred senv (H.PAnd ps) = concatMap (scrapePred senv) ps-scrapePred senv (H.Reft e)  = concatMap (mkQual senv) (F.concConjuncts e)---- NOTE: Constraints.mkQual will do extra stuff like generalizing the sorts...-mkQual :: BindEnv -> F.Expr -> [ F.Qualifier ]-mkQual env e = [ mkScrapeQual xts' e | xts' <- shiftCycle xts ]-  where-    xts = qualParams env e--mkScrapeQual :: [(F.Symbol, F.Sort)] -> F.Expr -> F.Qualifier-mkScrapeQual xts e = F.mkQual (F.symbol "AUTO") qParams body (F.dummyPos "")-  where-    qParams = [ F.QP {F.qpSym = y, F.qpPat = F.PatNone, F.qpSort = t} | (_, y, t) <- xyts ]-    xyts    = zipWith (\i (x, t) -> (x, F.bindSymbol i, t)) [0..] xts-    su      = F.mkSubst [ (x, F.expr y) | (x, y, _) <- xyts ]-    body    = F.subst su e---shiftCycle :: [(F.Symbol, F.Sort)] -> [[(F.Symbol, F.Sort)]]-shiftCycle xts-  | n <= maxQualifierParams = recycle n xts-  | otherwise              = []-  where-    n                      = length xts--recycle :: Int -> [a] -> [[a]]-recycle 0 _      = []-recycle _ []     = []-recycle k (x:xs) = (x:xs) : recycle (k-1) (xs ++ [x])--maxQualifierParams :: Int-maxQualifierParams = 3--{--  1. Normalize the names-  2. Permute the args?- -}--qualParams :: BindEnv -> F.Expr -> [(F.Symbol, F.Sort)]-qualParams env e = [ (x, t) | (_, x, t) <- L.sortBy (comparing Down) ixts ]-  where-    xs = Misc.nubOrd (F.syms e)-    ixts = [ (i, x, t) | x <- xs, (t, i) <- Mb.maybeToList (lookupBindEnv x env) ]------------------------------------------------------------------------------------- | `BindEnv` maps each symbol to (sort, depth) pair, where shorter depths---    means bound "earlier" i.e. in (forall (x1:...) (forall (x2:...) ...)---    the depth of x1 is less than the depth of x2.---    We use the heuristic that the symbol with the "largest" depth is the---    "value-variable" in the qualifier.--data BindEnv = BindEnv-  { bSize  :: !Int-  , bBinds :: M.HashMap F.Symbol (F.Sort, Int)-  }--emptyBindEnv :: BindEnv-emptyBindEnv = BindEnv { bSize = 0, bBinds = mempty }--insertBindEnv :: H.Bind a -> BindEnv -> BindEnv-insertBindEnv b senv = BindEnv { bSize = n + 1, bBinds = M.insert x (t, n) (bBinds senv) }-  where-    n = bSize senv-    x = H.bSym b-    t = H.bSort b+hvarArg k i = F.intSymbol (F.suffixSymbol hvarPrefix (H.hvName k)) i -lookupBindEnv :: F.Symbol -> BindEnv -> Maybe (F.Sort, Int)-lookupBindEnv x env = M.lookup x (bBinds env)+hvarPrefix :: F.Symbol+hvarPrefix = F.symbol "nnf_arg"
src/Language/Fixpoint/Horn/Parse.hs view
@@ -7,137 +7,32 @@   , hPredP   , hQualifierP   , hVarP-  , exprP-  , sortP ) where -import qualified Language.Fixpoint.Parse        as FP (Parser, addNumTyCon, lexeme', locLexeme', reserved', reservedOp', symbolR, upperIdR, lowerIdR, stringR, naturalR, mkFTycon, kvarP)+import           Language.Fixpoint.Parse import qualified Language.Fixpoint.Types        as F import qualified Language.Fixpoint.Horn.Types   as H import           Text.Megaparsec                hiding (State)-import           Text.Megaparsec.Char           (space1, string, char)+import           Text.Megaparsec.Char           (char) import qualified Data.HashMap.Strict            as M-import qualified Data.Text as T-import qualified Text.Megaparsec.Char.Lexer  as L -type FParser = FP.Parser--fAddNumTyCon :: F.Symbol -> FP.Parser ()-fAddNumTyCon = FP.addNumTyCon--lexeme :: FParser a -> FParser a-lexeme = FP.lexeme' spaces--locLexeme :: FP.Parser a -> FP.Parser (F.Located a)-locLexeme = FP.locLexeme' spaces---- | 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 :: FParser ()-spaces =-  L.space-    space1-    lineComment-    blockComment--lineComment :: FParser ()-lineComment = L.skipLineComment ";"--blockComment :: FParser ()-blockComment = L.skipBlockComment "/* " "*/"--reserved :: String -> FParser ()-reserved = FP.reserved' spaces--reservedOp :: String -> FParser ()-reservedOp = FP.reservedOp' spaces--sym :: String -> FParser String-sym x = lexeme (string x)--parens :: FParser a -> FParser a-parens = between (sym "(") (sym ")")--stringLiteral :: FParser String-stringLiteral = lexeme FP.stringR <?> "string literal"--symbolP :: FParser F.Symbol-symbolP = lexeme FP.symbolR <?> "identifier"--fIntP :: FParser Int-fIntP = fromInteger <$> natural--natural :: FParser Integer-natural = lexeme FP.naturalR <?> "nat literal"--double :: FParser Double-double = lexeme L.float <?> "float literal"---locUpperIdP, locSymbolP :: FParser F.LocSymbol-locUpperIdP = locLexeme FP.upperIdR-locSymbolP  = locLexeme FP.symbolR--upperIdP :: FP.Parser F.Symbol-upperIdP = lexeme FP.upperIdR <?> "upperIdP"--lowerIdP :: FP.Parser F.Symbol-lowerIdP = lexeme FP.lowerIdR <?> "upperIdP"--fTyConP :: FParser F.FTycon-fTyConP-  =   (reserved "int"     >> return F.intFTyCon)-  <|> (reserved "Integer" >> return F.intFTyCon)-  <|> (reserved "Int"     >> return F.intFTyCon)-  <|> (reserved "real"    >> return F.realFTyCon)-  <|> (reserved "bool"    >> return F.boolFTyCon)-  <|> (reserved "num"     >> return F.numFTyCon)-  <|> (reserved "Str"     >> return F.strFTyCon)-  <|> (FP.mkFTycon        =<<  locUpperIdP)---fTrueP :: FP.Parser F.Expr-fTrueP = reserved "true"  >> return F.PTrue--fFalseP :: FP.Parser F.Expr-fFalseP = reserved "false" >> return F.PFalse--fSymconstP :: FP.Parser F.SymConst-fSymconstP =  F.SL . T.pack <$> stringLiteral---- | Parser for literal numeric constants: floats or integers without sign.-constantP :: FParser F.Constant-constantP =-     try (F.R <$> double)   -- float literal- <|> F.I <$> natural        -- nat literal- --------------------------------------------------------------------------------hornP :: FParser H.TagQuery+hornP :: Parser (H.TagQuery, [String]) ------------------------------------------------------------------------------- hornP = do-  spaces   hThings <- many hThingP-  pure (mkQuery hThings)+  pure (mkQuery hThings, [ o | HOpt o <- hThings ])  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.qEqns  =              [ e     | HDef e   <- things ]-  , H.qDefs  =              [ e     | HDfn e   <- things ]-  , H.qMats  =              [ m     | HMat m   <- things ]-  , H.qData  =              [ dd    | HDat dd  <- things ]-  , H.qOpts  =              [ o     | HOpt o   <- things ]-  , H.qNums  =              [ s     | HNum s   <- things ]-  , H.qKuts  =              [ k     | HKut k   <- 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@@ -151,17 +46,14 @@   -- for uninterpred functions and ADT constructors   | HCon  F.Symbol F.Sort   | HDis  F.Symbol F.Sort-  | HDef  F.Equation-  | HDfn  F.Equation+  | HDef  F.Equation    | HMat  F.Rewrite-  | HDat !F.DataDecl+  | HDat  F.DataDecl   | HOpt !String-  | HNum  F.Symbol-  | HKut  F.KVar   deriving (Functor) -hThingP :: FParser (HThing H.Tag)-hThingP  = spaces >> parens body+hThingP :: Parser (HThing H.Tag)+hThingP  = parens body   where     body =  HQual <$> (reserved "qualif"     *> hQualifierP)         <|> HCstr <$> (reserved "constraint" *> hCstrP)@@ -170,198 +62,64 @@         <|> HCon  <$> (reserved "constant"   *> symbolP) <*> sortP         <|> HDis  <$> (reserved "distinct"   *> symbolP) <*> sortP         <|> HDef  <$> (reserved "define"     *> defineP)-        <|> HDfn  <$> (reserved "define_fun" *> defineP)         <|> HMat  <$> (reserved "match"      *> matchP)-        <|> HDat  <$> (reserved "datatype"   *> dataDeclP)-        <|> HNum  <$> (reserved "numeric"    *> numericDeclP)-        <|> HKut  <$> (reserved "cut"        *> FP.kvarP)--numericDeclP :: FParser F.Symbol-numericDeclP = do-  x <- F.val <$> locUpperIdP-  fAddNumTyCon x-  pure x+        <|> HDat  <$> (reserved "data"       *> dataDeclP)  --------------------------------------------------------------------------------hCstrP :: FParser (H.Cstr H.Tag)+hCstrP :: Parser (H.Cstr H.Tag) --------------------------------------------------------------------------------hCstrP =  try (parens body)-      <|> H.Head <$> hPredP                            <*> pure H.NoTag+hCstrP = parens body   where-    body =  H.CAnd <$> (reserved "and"    *> many hCstrP)-        <|> H.All  <$> (reserved "forall" *> hBindP)  <*> hCstrP-        <|> H.Head <$> (reserved "tag"    *> hPredP)  <*> (H.Tag <$> stringLiteral)+    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 :: FParser (H.Bind H.Tag)+hBindP :: Parser H.Bind hBindP   = parens $ do   (x, t) <- symSortP-  H.Bind x t <$> hPredP <*> pure H.NoTag+  p      <- hPredP+  return  $ H.Bind x t p  --------------------------------------------------------------------------------hPredP :: FParser H.Pred+hPredP :: Parser H.Pred ------------------------------------------------------------------------------- hPredP = parens body   where-    body =  H.Var  <$> kvSymP <*> some exprP+    body =  H.Var  <$> kvSymP                           <*> some symbolP         <|> H.PAnd <$> (reserved "and" *> some hPredP)-        <|> H.Reft <$> exprP+        <|> H.Reft <$> predP -kvSymP :: FParser F.Symbol+kvSymP :: Parser F.Symbol kvSymP = char '$' *> symbolP  ------------------------------------------------------------------------------- -- | Qualifiers --------------------------------------------------------------------------------hQualifierP :: FParser F.Qualifier+hQualifierP :: Parser F.Qualifier hQualifierP = do   pos    <- getSourcePos   n      <- upperIdP   params <- parens (some symSortP)-  body   <- exprP+  body   <- parens predP   return  $ F.mkQual n (mkParam <$> params) body pos  mkParam :: (F.Symbol, F.Sort) -> F.QualParam-mkParam (x, t) = case F.stripSuffix (F.symbol (T.pack "#")) x of-  Just x' -> F.QP x' F.PatLit  t-  Nothing -> F.QP x  F.PatNone t+mkParam (x, t) = F.QP x F.PatNone t  ------------------------------------------------------------------------------- -- | Horn Variables ------------------------------------------------------------------------------- -hVarP :: FParser (H.Var H.Tag)-hVarP = H.HVar <$> kvSymP <*> parens (some sortP) <*> pure H.NoTag+hVarP :: Parser (H.Var H.Tag)+hVarP = H.HVar <$> kvSymP <*> parens (some (parens sortP)) <*> pure H.NoTag   ------------------------------------------------------------------------------- -- | Helpers --------------------------------------------------------------------------------sPairP :: FParser a -> FParser b -> FParser (a, b)-sPairP aP bP = parens ((,) <$> aP <*> bP) -sMany :: FParser a -> FParser [a]-sMany p = parens (many p)+symSortP :: Parser (F.Symbol, F.Sort)+symSortP = parens ((,) <$> symbolP <*> sortP)  -symSortP :: FParser (F.Symbol, F.Sort)-symSortP = sPairP  symbolP sortP--- symSortP = fParens ((,) <$> fSymbolP <*> sortP)--dataDeclP :: FParser F.DataDecl-dataDeclP = do-  (tc, n) <- sPairP fTyConP fIntP-  ctors   <- sMany dataCtorP-  pure     $ F.DDecl tc n ctors--dataCtorP :: FParser F.DataCtor-dataCtorP = parens (F.DCtor <$> locSymbolP <*> sMany dataFieldP)--dataFieldP :: FParser F.DataField-dataFieldP = uncurry F.DField <$> sPairP locSymbolP sortP--bindsP :: FParser [(F.Symbol, F.Sort)]-bindsP = sMany bindP--bindP :: FParser (F.Symbol, F.Sort)-bindP = sPairP symbolP sortP---- | We only support lets with a single binder, but we parse this as a "singleton list"--- to be forward compatible with multiple binders. Note that the semantics of multiple--- binders in smtlib is *simulatenous substitution*, so they cannot be desugared to nested--- lets.-exprBindsP :: FParser (F.Symbol, F.Expr)-exprBindsP = parens exprBindP--exprBindP :: FParser (F.Symbol, F.Expr)-exprBindP = sPairP symbolP exprP--defineP :: FParser F.Equation-defineP = do-  name   <- symbolP-  xts    <- bindsP-  s      <- sortP-  body   <- exprP-  return  $ F.mkEquation name xts body s--matchP :: FParser F.Rewrite-matchP = do-  f    <- symbolP-  d:xs <- parens (some symbolP)-  F.SMeasure f d xs <$> exprP--sortP :: FParser F.Sort-sortP =  (string "@" >> (F.FVar <$> parens fIntP))-     <|> (reserved "Int"  >> return F.FInt)-     <|> (reserved "Real" >> return F.FReal)-     <|> (reserved "Frac" >> return F.FFrac)-     <|> (reserved "num" >> return  F.FNum)-     <|> (F.fAppTC <$> fTyConP <*> pure [])-     <|> (F.FObj . F.symbol <$> lowerIdP)-     <|> try (parens (reserved "func" >> (mkFunc <$> fIntP <*> sMany sortP <*> sortP)))-     <|> try (parens (reserved "list" >> (mkList <$> sortP)))-     <|> parens (F.fAppTC <$> fTyConP <*> many sortP)-     <|> (F.FNatNum <$> natural)--mkFunc :: Int -> [F.Sort] -> F.Sort -> F.Sort-mkFunc n ss s = F.mkFFunc n (ss ++ [s])--mkList :: F.Sort -> F.Sort-mkList s = F.fAppTC F.listFTyCon [s]--exprP :: FParser F.Expr-exprP-  =   fTrueP-  <|> fFalseP-  <|> (F.ESym <$> fSymconstP)-  <|> (F.ECon <$> constantP)-  <|> (F.EVar <$> symbolP)-  <|> parens pExprP--pExprP :: FParser F.Expr-pExprP-  =   (reserved   "if"     >> (F.EIte   <$> exprP <*> exprP <*> exprP))-  <|> (reserved   "let"    >> (uncurry F.ELet   <$> exprBindsP <*> exprP))-  <|> (reserved   "lit"    >> (mkLit    <$> stringLiteral <*> sortP))-  <|> (reserved   "cast"   >> (F.ECst   <$> exprP <*> sortP))-  <|> (reserved   "not"    >> (F.PNot   <$> exprP))-  <|> (reservedOp "=>"     >> (F.PImp   <$> exprP <*> exprP))-  <|> (reservedOp "<=>"    >> (F.PIff   <$> exprP <*> exprP))-  <|> (reserved   "and"    >> (F.PAnd   <$> many exprP))-  <|> (reserved   "or"     >> (F.POr    <$> many exprP))-  <|> (reserved   "forall" >> (F.PAll   <$> bindsP <*> exprP))-  <|> (reserved   "exists" >> (F.PExist <$> bindsP <*> exprP))-  <|> (reserved   "lam"    >> (F.ELam   <$> bindP <*> exprP))-  <|> (reserved   "coerce" >> (F.ECoerc <$> sortP <*> sortP <*> exprP))-  <|> (reserved   "ETApp"  >> (F.ETApp  <$> exprP <*> sortP))-  <|> (reserved   "ETAbs"  >> (F.ETAbs  <$> exprP <*> symbolP))-  <|> try (F.EBin  <$> bopP <*> exprP <*> exprP)-  <|> try (F.PAtom <$> brelP <*> exprP <*> exprP)-  <|> try (sym "-" >> (F.ENeg <$> exprP))-  <|> (mkApp <$> some exprP)--mkLit :: String -> F.Sort -> F.Expr-mkLit l t = F.ECon (F.L (T.pack l) t)--mkApp :: [F.Expr] -> F.Expr-mkApp (e:es) = F.eApps e es-mkApp _      = error "impossible"--bopP :: FParser F.Bop-bopP-  =  (sym "+"   >> return F.Plus)- <|> (sym "-"   >> return F.Minus)- <|> (sym "*"   >> return F.Times)- <|> (sym "/"   >> return F.Div)- <|> (reserved "mod" >> return F.Mod)- <|> (sym "*."  >> return F.RTimes)- <|> (sym "/."  >> return F.RDiv)--brelP :: FParser F.Brel-brelP-  =  (sym "="  >> return F.Eq)- <|> (sym "!=" >> return F.Ne)- <|> (sym "~~" >> return F.Ueq)- <|> (sym "!~" >> return F.Une)- <|> (sym ">=" >> return F.Ge)- <|> (sym ">"  >> return F.Gt)- <|> (sym "<=" >> return F.Le)- <|> (sym "<"  >> return F.Lt)
src/Language/Fixpoint/Horn/Solve.hs view
@@ -15,72 +15,47 @@ import qualified Language.Fixpoint.Types        as F import qualified Language.Fixpoint.Types.Config as F 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 Text.PrettyPrint.HughesPJ.Compat ( render ) import Language.Fixpoint.Horn.Info ( hornFInfo ) -import Language.Fixpoint.Verbosity ( whenLoud )-import qualified Data.Aeson as Aeson+import System.Console.CmdArgs.Verbosity ( whenLoud )+ -- import Debug.Trace (traceM)  ---------------------------------------------------------------------------------- solveHorn :: F.Config -> IO ExitCode -----------------------------------------------------------------------------------solveHorn baseCfg0 = do-  q <- parseQuery baseCfg0-  let baseCfg = baseCfg0 { F.explicitKvars = True }+solveHorn cfg = do+  (q, opts) <- parseQuery cfg+     -- If you want to set --eliminate=none, you better make it a pragma-  let cfgElim = if F.eliminate baseCfg == F.None-                  then baseCfg { F.eliminate =  F.Some }-                  else baseCfg--  cfgPragmas <- F.withPragmas cfgElim (H.qOpts q)+  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 cfgPragmas) (saveHornQuery cfgPragmas q)+  when (F.save cfg) (saveHornQuery cfg q) -  r <- solve cfgPragmas q-  Solver.resultExitCode cfgPragmas r+  r <- solve cfg q+  Solver.resultExitCode cfg r -parseQuery :: F.Config -> IO H.TagQuery-parseQuery cfg+parseQuery :: F.Config -> IO (H.Query H.Tag, [String])+parseQuery cfg    | F.stdin cfg = Parse.parseFromStdIn H.hornP-  | json        = loadFromJSON file-  | otherwise   = Parse.parseFromFile H.hornP file-  where-    json  = Files.isExtFile Files.Json file-    file  = F.srcFile cfg--loadFromJSON :: FilePath -> IO H.TagQuery-loadFromJSON f = do-  r <- Aeson.eitherDecodeFileStrict f-  case r of-    Right v -> return v-    Left err -> error ("Error in loadFromJSON: " ++ err)+  | otherwise   = Parse.parseFromFile H.hornP (F.srcFile cfg)  saveHornQuery :: F.Config -> H.Query H.Tag -> IO () saveHornQuery cfg q = do-  saveHornSMT2 cfg q-  saveHornJSON cfg q--saveHornSMT2 :: F.ToHornSMT a => F.Config -> a -> IO ()-saveHornSMT2 cfg q = do   let hq   = F.queryFile Files.HSmt2 cfg   putStrLn $ "Saving Horn Query: " ++ hq ++ "\n"   Misc.ensurePath hq-  writeFile hq $ render (F.toHornSMT q)--saveHornJSON :: F.Config -> H.Query H.Tag -> IO ()-saveHornJSON cfg q = do-  let hjson   = F.queryFile Files.HJSON cfg-  putStrLn $ "Saving Horn Query: " ++ hjson ++ "\n"-  Misc.ensurePath hjson-  Aeson.encodeFile hjson q+  writeFile hq $ render (F.pprint q)  -----------------------------------------------------------------------------------eliminate :: (F.Fixpoint a, F.PPrint a) => F.Config -> H.Query a -> IO (H.Query a)+eliminate :: (F.PPrint a) => F.Config -> H.Query a -> IO (H.Query a) ---------------------------------------------------------------------------------- eliminate cfg q   | F.eliminate cfg == F.Existentials = do@@ -96,9 +71,10 @@ solve :: (F.PPrint a, NFData a, F.Loc a, Show a, F.Fixpoint a) => F.Config -> H.Query a        -> IO (F.Result (Integer, a)) -----------------------------------------------------------------------------------solve cfg qry = do-  let c = Tx.uniq $ Tx.flatten $ H.qCstr qry+solve cfg q = do+  let c = Tx.uniq $ Tx.flatten $ H.qCstr q   whenLoud $ putStrLn "Horn Uniq:"   whenLoud $ putStrLn $ F.showpp c-  q <- eliminate cfg ({- void $ -} qry { H.qCstr = c })+  q <- eliminate cfg ({- void $ -} q { H.qCstr = c })   Solver.solve cfg (hornFInfo cfg q)+
src/Language/Fixpoint/Horn/Transformations.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE LambdaCase  #-} {-# LANGUAGE FlexibleInstances  #-}--{-# OPTIONS_GHC -Wno-orphans        #-}-+{-# LANGUAGE TupleSections  #-} module Language.Fixpoint.Horn.Transformations (     uniq   , flatten@@ -23,19 +22,15 @@ import qualified Data.HashMap.Strict          as M import           Data.String                  (IsString (..)) import           Data.Either                  (partitionEithers, rights)-#if MIN_VERSION_base(4,20,0) import           Data.List                    (nub)-#else-import           Data.List                    (nub, foldl')-#endif import qualified Data.Set                     as S import qualified Data.HashSet                 as HS import qualified Data.Graph                   as DG import           Control.Monad.State import           Data.Maybe                   (catMaybes, mapMaybe, fromMaybe) import           Language.Fixpoint.Types.Visitor as V-import           Language.Fixpoint.Verbosity-import           Data.Bifunctor (first, second)+import           System.Console.CmdArgs.Verbosity+import           Data.Bifunctor (second) import System.IO (hFlush, stdout) -- import qualified Debug.Trace as DBG @@ -55,15 +50,13 @@ printPiSols :: (F.PPrint a1, F.PPrint a2, F.PPrint a3) =>                M.HashMap a1 ((a4, a2), a3) -> IO () printPiSols piSols =-  mapM_-    (\(piVar', ((_, args), cstr)) -> do-                  putStr $ F.showpp piVar'+  sequence_ $ ((\(piVar, ((_, args), cstr)) -> do+                  putStr $ F.showpp piVar                   putStr " := "                   putStrLn $ F.showpp args                   putStrLn $ F.showpp cstr                   putStr "\n"-                  hFlush stdout)-    (M.toList piSols)+                  hFlush stdout) <$> M.toList piSols) ---------------  -- type Sol a = M.HashMap F.Symbol (Either (Either [[Bind]] (Cstr a)) F.Expr)@@ -75,19 +68,16 @@ -- can depend on other ks, pis cannot directly depend on other pis -- - predicate for exists binder is `true`. (TODO: is this pre stale?) -solveEbs :: (F.Fixpoint a, F.PPrint a) => F.Config -> Query a -> IO (Query a)+solveEbs :: (F.PPrint a) => F.Config -> Query a -> IO (Query a) -------------------------------------------------------------------------------solveEbs cfg query@(Query {}) = do-  let cons = qCon query-  let cstr = qCstr query-  let dist = qDis query+solveEbs cfg query@(Query qs vs c cons dist eqns mats dds) = do   -- clean up-  let normalizedC = flatten . pruneTauts $ hornify cstr+  let normalizedC = flatten . pruneTauts $ hornify c   whenLoud $ putStrLn "Normalized EHC:"   whenLoud $ putStrLn $ F.showpp normalizedC    -- short circuit if no ebinds are present-  if isNNF cstr then pure $ query{ qCstr = normalizedC } 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:"@@ -95,13 +85,9 @@   whenLoud $ putStrLn $ F.showpp poked    whenLoud $ putStrLn "Skolemized + split:"-  let (_horn, _side) = case split poked of-                        (Just h, Just s) -> (h, s)-                        _ -> error "Couldn't split poked in solveEbs"-+  let (Just _horn, Just _side) = split poked   let horn = flatten . pruneTauts $ _horn   let side = flatten . pruneTauts $ _side-   whenLoud $ putStrLn $ F.showpp (horn, side)    -- collect predicate variables@@ -111,48 +97,46 @@   let acyclicKs = kvars `S.difference` cuts    whenLoud $ putStrLn "solved acyclic kvars:"-  let (hornk, sidek) = elimKs' (S.toList acyclicKs) (horn, side)-  whenLoud $ putStrLn $ F.showpp hornk-  whenLoud $ putStrLn $ F.showpp sidek+  let (horn', side') = elimKs' (S.toList acyclicKs) (horn, side)+  whenLoud $ putStrLn $ F.showpp horn'+  whenLoud $ putStrLn $ F.showpp side'    -- if not $ S.null cuts then error $ F.showpp $ S.toList cuts else pure ()   let elimCutK k c = doelim k [] c-      hornCut = foldr elimCutK hornk cuts-      sideCut = foldr elimCutK sidek cuts+  horn' <- pure $ foldr elimCutK horn' cuts+  side' <- pure $ foldr elimCutK side' cuts    whenLoud $ putStrLn "pi defining constraints:"-  let piSols = M.fromList $ fmap (\pivar -> (pivar, piDefConstr pivar hornCut)) (S.toList pivars)+  let piSols = M.fromList $ fmap (\pivar -> (pivar, piDefConstr pivar horn')) (S.toList pivars)   whenLoud $ printPiSols piSols    whenLoud $ putStrLn "solved pis:"-  let solvedPiCstrs = solPis cfg (S.fromList $ M.keys cons ++ M.keys dist) piSols+  let solvedPiCstrs = solPis (S.fromList $ M.keys cons ++ M.keys dist) piSols   whenLoud $ putStrLn $ F.showpp solvedPiCstrs    whenLoud $ putStrLn "solved horn:"-  let solvedHorn = substPiSols solvedPiCstrs hornCut+  let solvedHorn = substPiSols solvedPiCstrs horn'   whenLoud $ putStrLn $ F.showpp solvedHorn    whenLoud $ putStrLn "solved side:"-  let solvedSide = substPiSols solvedPiCstrs sideCut+  let solvedSide = substPiSols solvedPiCstrs side'   whenLoud $ putStrLn $ F.showpp solvedSide -  pure (query { qCstr = CAnd [solvedHorn, solvedSide] })+  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)` piDefConstr :: F.Symbol -> Cstr a -> ((F.Symbol, [F.Symbol]), Cstr a)-piDefConstr k c = ((head syms, head formalSyms), defCStr)+piDefConstr k c = ((head ns, head formals), defC)   where-    (syms, formalSyms, defCStr) = case go c of+    (ns, formals, defC) = case go c of       (ns, formals, Just defC) -> (ns, formals, defC)       (_, _, Nothing) -> error $ "pi variable " <> F.showpp k <> " has no defining constraint." -    -- TODO: generalize the `expectVar` business below to handle arbitrary expressions-    -- https://github.com/ucsd-progsys/liquid-fixpoint/pull/818#discussion_r2643206366     go :: Cstr a -> ([F.Symbol], [[F.Symbol]], Maybe (Cstr a))-    go (CAnd cs) = (\(as, bs, mcs) -> (concat as, concat bs, cAndMaybes mcs)) $ unzip3 $ go <$> cs-    go (All b@(Bind n _ (Var k' xs) _) c')-      | k == k' = ([n], [S.toList $ S.fromList (expectVar <$> xs) `S.difference` S.singleton n], Just c')+    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 = map3 (fmap (All b)) (go c')     go (All b c') = map3 (fmap (All b)) (go c')     go _ = ([], [], Nothing)@@ -162,27 +146,23 @@       [] -> Nothing       cs -> Just $ CAnd cs -expectVar :: F.Expr -> F.Symbol-expectVar (F.EVar s) = s-expectVar _ = error "expectVar: expected variable"- map3 :: (c -> d) -> (a, b, c) -> (a, b, d) map3 f (x, y, z) = (x, y, f z)  -- | Solve out the given pivars-solPis :: F.Config -> S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> M.HashMap F.Symbol Pred-solPis cfg measures piSolsMap = go (M.toList piSolsMap) piSolsMap+solPis :: S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> M.HashMap F.Symbol Pred+solPis measures piSols = go (M.toList piSols) piSols   where-    go ((pi', ((n, xs), c)):pis) piSols = M.insert pi' solved $ go pis piSols-      where solved = solPi cfg measures pi' n (S.fromList xs) piSols c+    go ((pi, ((n, xs), c)):pis) piSols = M.insert pi solved $ go pis piSols+      where solved = solPi measures pi n (S.fromList xs) piSols c     go [] _ = mempty  -- TODO: rewrite to use CC-solPi :: F.Config -> S.Set F.Symbol -> F.Symbol -> F.Symbol -> S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> Cstr a -> Pred-solPi cfg measures basePi n args piSols cstr = trace ("\n\nsolPi: " <> F.showpp basePi <> "\n\n" <> F.showpp n <> "\n" <> F.showpp (S.toList args) <> "\n" <> F.showpp ((\(a, _, c) -> (a, c)) <$> edges) <> "\n" <> F.showpp (sols n) <> "\n" <> F.showpp rewritten <> "\n" <> F.showpp cstr <> "\n\n") $ PAnd rewritten+solPi :: S.Set F.Symbol -> F.Symbol -> F.Symbol -> S.Set F.Symbol -> M.HashMap F.Symbol ((F.Symbol, [F.Symbol]), Cstr a) -> Cstr a -> Pred+solPi measures basePi n args piSols c = trace ("\n\nsolPi: " <> F.showpp basePi <> "\n\n" <> F.showpp n <> "\n" <> F.showpp (S.toList args) <> "\n" <> F.showpp ((\(a, _, c) -> (a, c)) <$> edges) <> "\n" <> F.showpp (sols n) <> "\n" <> F.showpp rewritten <> "\n" <> F.showpp c <> "\n\n") $ PAnd $ rewritten   where-    rewritten = rewriteWithEqualities cfg measures n args equalities-    equalities = (nub . fst) $ go (S.singleton basePi) cstr+    rewritten = rewriteWithEqualities measures n args equalities+    equalities = (nub . fst) $ go (S.singleton basePi) c     edges = eqEdges args mempty equalities     (eGraph, vf, lookupVertex) = DG.graphFromEdges edges     sols x = case lookupVertex x of@@ -190,16 +170,17 @@       Just vertex -> nub $ filter (/= F.EVar x) $ mconcat [es | ((_, es), _, _) <- vf <$> DG.reachable eGraph vertex]      go :: S.Set F.Symbol -> Cstr a -> ([(F.Symbol, F.Expr)], S.Set F.Symbol)-    go visitedSyms (Head p _) = (collectEqualities p, visitedSyms)-    go visitedSyms (CAnd cs) = foldl' (\(eqs, visited) c -> let (eqs', visited') = go visited c in (eqs' <> eqs, visited')) (mempty, visitedSyms) cs-    go visited (All (Bind _ _ (Var pi' _) _) c)-      | S.member pi' visited = go visited c-      | otherwise = let (_, defC) = (piSols M.! pi')-                        (eqs', newVisited) = go (S.insert pi' visited) defC+    go visited (Head p _) = (collectEqualities p, visited)+    go visited (CAnd cs) = foldl (\(eqs, visited) c -> let (eqs', visited') = go visited c in (eqs' <> eqs, visited')) (mempty, visited) cs+    go visited (All (Bind _ _ (Var pi _)) c)+      | S.member pi visited = go visited c+      | otherwise = let (_, defC) = (piSols M.! pi)+                        (eqs', newVisited) = go (S.insert pi visited) defC                         (eqs'', newVisited') = go newVisited c in           (eqs' <> eqs'', newVisited')-    go visited (All (Bind _ _ p _) c) = let (eqs, visited') = go visited c in+    go visited (All (Bind _ _ p) c) = let (eqs, visited') = go visited c in       (eqs <> collectEqualities p, visited')+    go _ Any{} = error "exists should not be present in piSols"  ------------------------------------------------------------------------------ {- | pokec skolemizes the EHC into an HC + side condition@@ -252,8 +233,17 @@   where     go _ (Head c l) = Head c l     go xs (CAnd c)   = CAnd (go xs <$> c)-    go xs (All b c2) = All b $ go (bSym b : xs) c2+    go xs (All b c2) = All b $ go ((bSym b):xs) c2+    go xs (Any b@(Bind x t p) c2) = CAnd [All b' $ CAnd [Head p l, go (x:xs) c2], Any b (Head pi l)]+      -- TODO: actually use the renamer?+      where+        b' = Bind x t pi+        pi = piVar x xs+        l  = cLabel c2 +piVar :: F.Symbol -> [F.Symbol] -> Pred+piVar x xs = Var (piSym x) (x:xs)+ piSym :: F.Symbol -> F.Symbol piSym s = fromString $ "π" ++ F.symbolString s @@ -328,10 +318,11 @@   where (nosides, sides) = unzip $ split <$> cs split (All b c) = (All b <$> c', All b <$> c'')     where (c',c'') = split c+split c@Any{} = (Nothing, Just c) split c@Head{} = (Just c, Nothing)  andMaybes :: [Maybe (Cstr a)] -> Maybe (Cstr a)-andMaybes mcs = case catMaybes mcs of+andMaybes cs = case catMaybes cs of                  [] -> Nothing                  [c] -> Just c                  cs -> Just $ CAnd cs@@ -387,29 +378,28 @@ elimPis [] cc = cc elimPis (n:ns) (horn, side) = elimPis ns (apply horn, apply side) -- TODO: handle this error?-  where nSol' = case defs n horn of-                 Just nSol -> nSol-                 Nothing -> error "Unexpected nothing elimPis"--        apply = applyPi (piSym n) nSol'+  where Just nSol = defs n horn+        apply = applyPi (piSym n) nSol  -- TODO: PAnd may be a problem applyPi :: F.Symbol -> Cstr a -> Cstr a -> Cstr a-applyPi k defCstr (All (Bind x t (Var k' _xs) ann) c)+applyPi k defs (All (Bind x t (Var k' _xs)) c)   | k == k'-  = All (Bind x t (Reft $ cstrToExpr defCstr) ann) c+  = All (Bind x t (Reft $ cstrToExpr defs)) c applyPi k bp (CAnd cs)   = CAnd $ applyPi k bp <$> cs applyPi k bp (All b c)   = All b (applyPi k bp c)-applyPi k defCstr (Head (Var k' _xs) a)+applyPi k bp (Any b c)+  = Any b (applyPi k bp c)+applyPi k defs (Head (Var k' _xs) a)   | k == k'   -- what happens when pi's appear inside the defs for other pis?   -- this shouldn't happen because there should be a strict   --  pi -> k -> pi structure   -- but that comes from the typing rules, not this format, so let's make   -- it an invariant of solveEbs above-  = Head (Reft $ cstrToExpr defCstr) a+  = Head (Reft $ cstrToExpr defs) a applyPi _ _ (Head p a) = Head p a  -- | The defining constraints for a pivar@@ -463,21 +453,23 @@  defs :: F.Symbol -> Cstr a -> Maybe (Cstr a) defs x (CAnd cs) = andMaybes $ defs x <$> cs-defs x (All (Bind x' _ _ _) c)+defs x (All (Bind x' _ _) c)   | x' == x   = pure c defs x (All _ c) = defs x c defs _ (Head _ _) = Nothing+defs _ (Any _ _) =  error "defs should be run only after noside and poke"  cstrToExpr :: Cstr a -> F.Expr cstrToExpr (Head p _) = predToExpr p cstrToExpr (CAnd cs) = F.PAnd $ cstrToExpr <$> cs-cstrToExpr (All (Bind x t p _) c) = F.PAll [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c+cstrToExpr (All (Bind x t p) c) = F.PAll [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c+cstrToExpr (Any (Bind x t p) c) = F.PExist [(x,t)] $ F.PImp (predToExpr p) $ cstrToExpr c  predToExpr :: Pred -> F.Expr predToExpr (Reft e) = e-predToExpr (Var k xs) = F.PKVar (F.KV k) M.empty (F.toKVarSubst $ M.fromList su)-  where su = zip (kargs k) xs+predToExpr (Var k xs) = F.PKVar (F.KV k) (F.Su $ M.fromList su)+  where su = zip (kargs k) (F.EVar <$> xs) predToExpr (PAnd ps) = F.PAnd $ predToExpr <$> ps  ------------------------------------------------------------------------------@@ -534,7 +526,7 @@ -- exists in the positive positions (which will stay exists when we go to -- prenex) may give us a lot of trouble during _quantifier elimination_ -- tx :: F.Symbol -> [[Bind]] -> Pred -> Pred--- tx k bss = trans (defaultFolder { txExpr = existentialPackage, ctxExpr = ctxKV }) M.empty ()+-- tx k bss = trans (defaultVisitor { txExpr = existentialPackage, ctxExpr = ctxKV }) M.empty () --   where --   splitBinds xs = unzip $ (\(Bind x t p) -> ((x,t),p)) <$> xs --   cubeSol su (Bind _ _ (Reft eqs):xs)@@ -555,15 +547,16 @@ --   ctxKV m _ = m  -- Visitor only visit Exprs in Pred!-instance V.Foldable Pred where-  foldE v c (PAnd ps) = PAnd <$> mapM (foldE v c) ps-  foldE v c (Reft e) = Reft <$> foldE v c e-  foldE _ _ var      = pure var+instance V.Visitable Pred where+  visit v c (PAnd ps) = PAnd <$> mapM (visit v c) ps+  visit v c (Reft e) = Reft <$> visit v c e+  visit _ _ var      = pure var -instance V.Foldable (Cstr a) where-  foldE v c (CAnd cs) = CAnd <$> mapM (foldE v c) cs-  foldE v c (Head p a) = Head <$> foldE v c p <*> pure a-  foldE v ctx (All (Bind x t p l) c) = All <$> (Bind x t <$> foldE v ctx p <*> pure l) <*> foldE v ctx c+instance V.Visitable (Cstr a) where+  visit v c (CAnd cs) = CAnd <$> mapM (visit v c) cs+  visit v c (Head p a) = Head <$> visit v c p <*> pure a+  visit v ctx (All (Bind x t p) c) = All <$> (Bind x t <$> visit v ctx p) <*> visit v ctx c+  visit v ctx (Any (Bind x t p) c) = All <$> (Bind x t <$> visit v ctx p) <*> visit v ctx c  ------------------------------------------------------------------------------ -- | Quantifier elimination for use with implicit solver@@ -620,15 +613,15 @@ --     equalities = collectEqualities c --     ps = rewriteWithEqualities n args equalities -rewriteWithEqualities :: F.Config -> S.Set F.Symbol -> F.Symbol -> S.Set F.Symbol -> [(F.Symbol, F.Expr)] -> [Pred]-rewriteWithEqualities cfg measures n args equalities = preds+rewriteWithEqualities :: S.Set F.Symbol -> F.Symbol -> S.Set F.Symbol -> [(F.Symbol, F.Expr)] -> [Pred]+rewriteWithEqualities measures n args equalities = preds   where     (eGraph, vf, lookupVertex) = DG.graphFromEdges $ eqEdges args mempty equalities      nResult = (n, makeWellFormed 15 $ sols n)     argResults = map (\arg -> (arg, makeWellFormed 15 $ sols arg)) (S.toList args) -    preds = mconcat $ (\(x, es) -> mconcat $ mkEquality x <$> es) <$> (nResult:argResults)+    preds = (mconcat $ (\(x, es) -> mconcat $ mkEquality x <$> es) <$> (nResult:argResults))      mkEquality x e = [Reft (F.PAtom F.Eq (F.EVar x) e)] @@ -637,22 +630,21 @@       Nothing -> []       Just vertex -> nub $ filter (/= F.EVar x) $ mconcat [es | ((_, es), _, _) <- vf <$> DG.reachable eGraph vertex] -    argsAndPrims = args `S.union` S.fromList (fst <$> F.toListSEnv thySyms) `S.union`measures-    thySyms = F.theorySymbols (F.solver cfg)+    argsAndPrims = args `S.union` (S.fromList $ map fst $ F.toListSEnv $ F.theorySymbols []) `S.union`measures      isWellFormed :: F.Expr -> Bool-    isWellFormed e = S.fromList (F.syms e) `S.isSubsetOf` argsAndPrims+    isWellFormed e = (S.fromList $ F.syms e) `S.isSubsetOf` argsAndPrims      makeWellFormed :: Int -> [F.Expr] -> [F.Expr]-    makeWellFormed 0 exprs = filter isWellFormed exprs -- We solved it. Maybe.-    makeWellFormed m exprs = makeWellFormed (m - 1) $ mconcat $ go <$> exprs+    makeWellFormed 0 es = filter isWellFormed es -- We solved it. Maybe.+    makeWellFormed n es = makeWellFormed (n - 1) $ mconcat $ go <$> es       where-        go expr = if isWellFormed expr then [expr] else rewrite rewrites [expr]+        go e = if isWellFormed e then [e] else rewrite rewrites [e]           where-            needSolving = S.fromList (F.syms expr) `S.difference` argsAndPrims+            needSolving = (S.fromList $ F.syms e) `S.difference` argsAndPrims             rewrites = (\x -> (x, filter (/= F.EVar x) $ sols x)) <$> S.toList needSolving             rewrite [] es = es-            rewrite ((x, rewriteExprs):rewriteExprs') es = rewrite rewriteExprs' $ [F.subst (F.mkSubst [(x, e')]) e | e' <- rewriteExprs, e <- es]+            rewrite ((x, rewrites):rewrites') es = rewrite rewrites' $ [F.subst (F.mkSubst [(x, e')]) e | e' <- rewrites, e <- es]  eqEdges :: S.Set F.Symbol ->            M.HashMap F.Symbol ([F.Symbol], [F.Expr]) ->@@ -687,10 +679,30 @@ substPiSols :: M.HashMap F.Symbol Pred -> Cstr a -> Cstr a substPiSols _ c@Head{} = c substPiSols piSols (CAnd cs) = CAnd $ substPiSols piSols <$> cs-substPiSols piSols (All (Bind x t p l) c)-  | Var k _ <- p = All (Bind x t (M.lookupDefault p k piSols) l) (substPiSols piSols c)-  | otherwise = All (Bind x t p l) (substPiSols piSols c)+substPiSols piSols (All (Bind x t p) c)+  | Var k _ <- p = All (Bind x t $ M.lookupDefault p k piSols) (substPiSols piSols c)+  | otherwise = All (Bind x t p) (substPiSols piSols c)+substPiSols piSols (Any (Bind n _ p) c)+  | Head (Var pi _) label <- c, Just sol <- M.lookup pi piSols =+    case findSol n sol of+      Just e -> Head (flatten $ PAnd $ (\pred -> F.subst1 pred (n, e)) <$> [p, sol]) label+      Nothing -> Head (Reft $ F.PAnd []) label+  | otherwise = error "missing piSol" +findSol :: F.Symbol -> Pred -> Maybe F.Expr+findSol x = go+  where+    go (Reft e) = findEq e+    go Var{} = Nothing+    go (PAnd ps) = case mapMaybe go ps of+      [] -> Nothing+      x:_ -> Just x++    findEq (F.PAtom F.Eq left right)+      | F.EVar y <- left, y == x = Just right+      | F.EVar y <- right, y == x = Just left+    findEq _ = Nothing+ ------------------------------------------------------------------------------ -- | uniq makes sure each binder has a unique name ------------------------------------------------------------------------------@@ -700,13 +712,18 @@ uniq c = evalState (uniq' c) M.empty  uniq' :: Cstr a -> State RenameMap (Cstr a)-uniq' (Head c a) = gets (Head . rename c) <*> pure a+uniq' (Head c a) = Head <$> gets (rename c) <*> pure a uniq' (CAnd c) = CAnd <$> mapM uniq' c-uniq' (All b@(Bind x _ _ _) c2) = do+uniq' (All b@(Bind x _ _) c2) = do     b' <- uBind b     c2' <- uniq' c2     modify $ popName x     pure $ All b' c2'+uniq' (Any b@(Bind x _ _) c2) = do+    b' <- uBind b+    c2' <- uniq' c2+    modify $ popName x+    pure $ Any b' c2'  popName :: F.Symbol -> RenameMap -> RenameMap popName x m = M.adjust (second tail) x m@@ -715,11 +732,12 @@ pushName Nothing = Just (0, [0]) pushName (Just (i, is)) = Just (i + 1, (i + 1):is) -uBind :: Bind a -> State RenameMap (Bind a)-uBind (Bind x t p l) = do+uBind :: Bind -> State RenameMap Bind+uBind (Bind x t p) = do    x' <- uVariable x+   -- nmap <- get    p' <- gets (rename p)-   pure $ Bind x' t p' l+   pure $ Bind x' t p'  uVariable :: IsString a => F.Symbol -> State RenameMap a uVariable x = do@@ -729,17 +747,18 @@  rename :: Pred -> RenameMap -> Pred rename e m = substPred (M.mapMaybeWithKey (\k v -> case v of-                                              (_, n:_) -> Just $ F.EVar $ numSym k n+                                              (_, n:_) -> Just $ numSym k n                                               _ -> Nothing) m) e  numSym :: IsString a => F.Symbol -> Integer -> a numSym s 0 = fromString $ F.symbolString s numSym s i = fromString $ F.symbolString s ++ "#" ++ show i -substPred :: M.HashMap F.Symbol F.Expr -> Pred -> Pred-substPred su (Reft e) = Reft $ F.subst (F.Su su) e+substPred :: M.HashMap F.Symbol F.Symbol -> Pred -> Pred+substPred su (Reft e) = Reft $ F.subst (F.Su $ F.EVar <$> su) e substPred su (PAnd ps) = PAnd $ substPred su <$> ps-substPred su (Var k xs) = Var k $ F.subst (F.Su su) <$> xs+substPred su (Var k xs) = Var k $ upd <$> xs+  where upd x = M.lookupDefault x x su  ------------------------------------------------------------------------------ -- | elim solves all of the KVars in a Cstr (assuming no cycles...)@@ -754,7 +773,7 @@ ------------------------------------------------------------------------------ elim c = if S.null $ boundKvars res then res else error "called elim on cyclic constraint"   where-  res = S.foldl' elim1 c (boundKvars c)+  res = S.foldl elim1 c (boundKvars c)  elim1 :: Cstr a -> F.Symbol -> Cstr a -- Find a `sol1` solution to a kvar `k`, and then subsitute in the solution for@@ -776,15 +795,17 @@     go c@(Head (Var k' _) _)       | k' == k = Right c     go (Head _ l) = Left l-    go c@(All (Bind _ _ p _) c') =-      if k `S.member` pKVars p then Right c else go c'+    go c@(All (Bind _ _ p) c') =+      if k `S.member` (pKVars p) then Right c else go c'+    go Any{} = error "any should not appear after poke"+     -- if kvar doesn't appear, then just return the left     -- if kvar appears in one child, that is the lca     -- but if kvar appear in multiple chlidren, this is the lca-    go cstr'@(CAnd cs) = case rights (go <$> cs) of-                       [] -> Left $ cLabel cstr'+    go c@(CAnd cs) = case rights (go <$> cs) of+                       [] -> Left $ cLabel c                        [c] -> Right c-                       _ -> Right cstr'+                       _ -> Right c   -- | A solution is a Hyp of binders (including one anonymous binder@@ -808,53 +829,59 @@ --  - `bss` is a Hyp, that tells us the solution to a Var, that is, --     a collection of cubes that we'll want to disjunct -sol1 :: F.Symbol -> Cstr a -> [([Bind a], [F.Expr])]+sol1 :: F.Symbol -> Cstr a -> [([Bind], [F.Expr])] sol1 k (CAnd cs) = sol1 k =<< cs-sol1 k (All b c) = first (b :) <$> sol1 k c+sol1 k (All b c) = (\(bs, eqs) -> (b:bs, eqs)) <$> sol1 k c sol1 k (Head (Var k' ys) _) | k == k'-  = [([], zipWith (F.PAtom F.Eq) (F.EVar <$> xs) ys)]+  = [([], zipWith (F.PAtom F.Eq) (F.EVar <$> xs) (F.EVar <$> ys))]   where xs = zipWith const (kargs k) ys sol1 _ (Head _ _) = []+sol1 _ (Any _ _) =  error "ebinds don't work with old elim"  kargs :: F.Symbol -> [F.Symbol]-kargs k = fromString . (("κarg$" ++ F.symbolString k ++ "#") ++) . show <$> [1 :: Integer ..]+kargs k = fromString . (("κarg$" ++ F.symbolString k ++ "#") ++) . show <$> [1..]  -- | -- >>> LET c = doParse' hCstrP "" "(forall ((z Int) ($k0 z)) ((z = x)))" -- >>> doelim "k0" [[Bind "v" F.boolSort (Reft $ F.EVar "v"), Bind "_" F.boolSort (Reft $ F.EVar "donkey")]]  c -- (forall ((v bool) (v)) (forall ((z int) (donkey)) ((z == x)))) -doelim :: F.Symbol -> [([Bind a], [F.Expr])] -> Cstr a -> Cstr a-doelim sym bss (CAnd cs)-  = CAnd $ doelim sym bss <$> cs-doelim sym bss (All (Bind sym' sort' p l) cstr) =-  case findKVarInGuard sym p of-    Right _ -> All (Bind sym' sort' p l) (doelim sym bss cstr)-    Left (kvars, preds) -> demorgan sym' sort' l kvars preds (doelim sym bss cstr) bss+doelim :: F.Symbol -> [([Bind], [F.Expr])] -> Cstr a -> Cstr a+doelim k bss (CAnd cs)+  = CAnd $ doelim k bss <$> cs+doelim k bss (All (Bind x t p) c) =+  case findKVarInGuard k p of+    Right _ -> All (Bind x t p) (doelim k bss c)+    Left (kvars, preds) -> demorgan x t kvars preds (doelim k bss c) bss   where-    demorgan :: F.Symbol -> F.Sort -> a -> [(F.Symbol, [F.Expr])] -> [Pred] -> Cstr a -> [([Bind a], [F.Expr])] -> Cstr a-    demorgan x t ann kvars preds cstr' bindExprs = mkAnd $ cubeSol <$> bindExprs-      where su = F.Su $ M.fromList $ concatMap (\(k, xs) -> zip (kargs k) xs) kvars+    demorgan :: F.Symbol -> F.Sort -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind], [F.Expr])] -> Cstr a+    demorgan x t kvars preds c bss = mkAnd $ cubeSol <$> bss+      where su = F.Su $ M.fromList $ concat $ map (\(k, xs) -> zip (kargs k) (F.EVar <$> xs)) kvars             mkAnd [c] = c             mkAnd cs = CAnd cs-            cubeSol (b:bs, eqs) = All b $ cubeSol (bs, eqs)-            cubeSol ([], eqs) = All (Bind x t (PAnd $ (Reft <$> F.subst su eqs) ++ (F.subst su <$> preds)) ann) cstr'+            cubeSol ((b:bs), eqs) = All b $ cubeSol (bs, eqs)+            cubeSol ([], eqs) = All (Bind x t (PAnd $ (Reft <$> F.subst su eqs) ++ (F.subst su <$> preds))) c doelim k _ (Head (Var k' _) a)   | k == k'   = Head (Reft F.PTrue) a doelim _ _ (Head p a) = Head p a +doelim k bss (Any (Bind x t p) c) =+  case findKVarInGuard k p of+    Right _ -> Any (Bind x t p) (doelim k bss c)+    Left (_, rights) -> Any (Bind x t (PAnd rights)) (doelim k bss c) -- TODO: for now we set the kvar to true. not sure if this is correct+ -- If k is in the guard then returns a Left list of that k and the remaining preds in the guard -- If k is not in the guard returns a Right of the pred-findKVarInGuard :: F.Symbol -> Pred -> Either ([(F.Symbol, [F.Expr])], [Pred]) Pred+findKVarInGuard :: F.Symbol -> Pred -> Either ([(F.Symbol, [F.Symbol])], [Pred]) Pred findKVarInGuard k (PAnd ps) =   if null lefts     then Right (PAnd ps) -- kvar not found-    else Left (newLefts, newRights)+    else Left $ (newLefts, newRights)   where findResults = findKVarInGuard k <$> ps-        (lefts, rights') = partitionEithers findResults-        newLefts = concatMap fst lefts-        newRights = concatMap snd lefts ++ rights'+        (lefts, rights) = partitionEithers findResults+        newLefts = concat $ map fst lefts+        newRights = concat (snd <$> lefts) ++ rights findKVarInGuard k p@(Var k' xs)   | k == k' = Left ([(k', xs)], [])   | otherwise = Right p@@ -878,7 +905,8 @@ boundKvars :: Cstr a -> S.Set F.Symbol boundKvars (Head p _)           = pKVars p boundKvars (CAnd c)             = mconcat $ boundKvars <$> c-boundKvars (All (Bind _ _ p _) c) = pKVars p <> boundKvars c+boundKvars (All (Bind _ _ p) c) = pKVars p <> boundKvars c+boundKvars (Any (Bind _ _ p) c) = pKVars p <> boundKvars c  pKVars :: Pred -> S.Set F.Symbol pKVars (Var k _) = S.singleton k@@ -890,19 +918,21 @@ isNNF Head{} = True isNNF (CAnd cs) = all isNNF cs isNNF (All _ c) = isNNF c+isNNF Any{} = False -calculateCuts :: (F.Fixpoint a, F.PPrint a) => F.Config -> Query a -> Cstr a -> S.Set F.Symbol-calculateCuts cfg q@(Query {}) nnf = convert $ FG.depCuts deps+calculateCuts :: F.Config -> Query a -> Cstr a -> S.Set F.Symbol+calculateCuts cfg (Query qs vs _ cons dist eqns mats dds) nnf = convert $ FG.depCuts deps   where-    (_, deps) = elimVars cfg (hornFInfo cfg $ q { qCstr = nnf })-    convert hashset = S.fromList $ F.kv <$> HS.toList hashset+    (_, 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 forgetPiVars _ c@Head{} = c forgetPiVars pis (CAnd cs) = CAnd $ forgetPiVars pis <$> cs-forgetPiVars pis (All (Bind x t p l) c)-  | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd []) l) $ forgetPiVars pis c-  | otherwise = All (Bind x t p l) $ forgetPiVars pis c+forgetPiVars pis (All (Bind x t p) c)+  | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd [])) $ forgetPiVars pis c+  | otherwise = All (Bind x t p) $ forgetPiVars pis c+forgetPiVars _ Any{} = error "shouldn't be present"  ----------------------------------------------------------------------------------- -- | Cleanup Horn Constraint@@ -930,30 +960,12 @@   flatten :: a -> a  instance Flatten (Cstr a) where-  flatten c = case flattenCstr c of-                Just c' -> c'-                Nothing -> CAnd []--  -- flatten (CAnd cstrs) = case flatten cstrs of-  --                       [c] -> c-  --                       cs -> CAnd cs-  -- flatten (Head p a) = Head (flatten p) a-  -- flatten (All (Bind x t p l) c) = All (Bind x t (flatten p) l) (flatten c)-  -- flatten (Any (Bind x t p l) c) = Any (Bind x t (flatten p) l) (flatten c)--flattenCstr :: Cstr a -> Maybe (Cstr a)-flattenCstr = go-  where-    go (Head (PAnd [])  _) = Nothing-    go (Head (Reft p) _)-      | F.isTautoPred p    = Nothing-    go (Head p a)          = Just $ Head (flatten p) a-    go (CAnd cs)           = mk . concatMap splitAnd $ mapMaybe flattenCstr cs-    go (All (Bind x t p l) c) = All (Bind x t (flatten p) l) <$> go c--    mk []  = Nothing-    mk [c] = Just c-    mk cs  = Just (CAnd cs)+  flatten (CAnd cs) = case flatten cs of+                        [c] -> c+                        cs -> CAnd cs+  flatten (Head p a) = Head (flatten p) a+  flatten (All (Bind x t p) c) = All (Bind x t (flatten p)) (flatten c)+  flatten (Any (Bind x t p) c) = Any (Bind x t (flatten p)) (flatten c)  instance Flatten [Cstr a] where   flatten (CAnd cs : xs) = flatten cs ++ flatten xs@@ -964,14 +976,8 @@     where fx = flatten x   flatten [] = [] ---splitAnd :: Cstr a -> [Cstr a]-splitAnd (CAnd cs) = cs-splitAnd c         = [c]- instance Flatten Pred where-  flatten (PAnd preds) = case flatten preds of+  flatten (PAnd ps) = case flatten ps of                         [p] -> p                         ps  -> PAnd ps   flatten p = p@@ -986,7 +992,7 @@   flatten []              = []  instance Flatten F.Expr where-  flatten (F.PAnd exprs) = case flatten exprs of+  flatten (F.PAnd ps) = case flatten ps of                          [p] -> p                          ps  -> F.PAnd ps   flatten p = p@@ -1002,18 +1008,19 @@ -- | Split heads into one for each kvar so that queries are always horn constraints hornify :: Cstr a -> Cstr a hornify (Head (PAnd ps) a) = CAnd (flip Head a <$> ps')-  where ps' = let (ks, qs) = splitP [] [] (flatten ps) in PAnd qs : ks+  where ps' = let (ks, qs) = split [] [] (flatten ps) in PAnd qs : ks -        splitP kacc pacc ((Var x xs):qs) = splitP (Var x xs : kacc) pacc qs-        splitP kacc pacc (q:qs) = splitP kacc (q:pacc) qs-        splitP kacc pacc [] = (kacc, pacc)-hornify (Head (Reft expr) a) = CAnd (flip Head a <$> (Reft (F.PAnd ps):(Reft <$> ks)))-  where (ks, ps) = splitP [] [] $ F.splitPAnd expr-        splitP kacc pacc (r@F.PKVar{}:rs) = splitP (r:kacc) pacc rs-        splitP kacc pacc (r:rs) = splitP kacc (r:pacc) rs-        splitP kacc pacc [] = (kacc,pacc)+        split kacc pacc ((Var x xs):qs) = split ((Var x xs):kacc) pacc qs+        split kacc pacc (q:qs) = split kacc (q:pacc) qs+        split kacc pacc [] = (kacc, pacc)+hornify (Head (Reft r) a) = CAnd (flip Head a <$> ((Reft $ F.PAnd ps):(Reft <$> ks)))+  where (ks, ps) = split [] [] $ F.splitPAnd r+        split kacc pacc (r@F.PKVar{}:rs) = split (r:kacc) pacc rs+        split kacc pacc (r:rs) = split kacc (r:pacc) rs+        split kacc pacc [] = (kacc,pacc) hornify (Head h a) = Head h a hornify (All b c) = All b $ hornify c+hornify (Any b c) = Any b $ hornify c hornify (CAnd cs) = CAnd $ hornify <$> cs  removeDuplicateBinders :: Cstr a -> Cstr a@@ -1021,7 +1028,8 @@   where     go _ c@Head{} = c     go xs (CAnd cs) = CAnd $ go xs <$> cs-    go xs (All b@(Bind x _ _ _) c) = if x `S.member` xs then go xs c else All b $ go (S.insert x xs) c+    go xs (All b@(Bind x _ _) c) = if x `S.member` xs then go xs c else All b $ go (S.insert x xs) c+    go xs (Any b c) = Any b $ go xs c  pruneTauts :: Cstr a -> Cstr a pruneTauts = fromMaybe (CAnd []) . go@@ -1034,6 +1042,7 @@     go (All b c) = do       c' <- go c       pure (All b c')+    go c@Any{} = Just c      goP (Reft e) = if F.isTautoPred e then Nothing else Just $ Reft e     goP p@Var{} = Just p
src/Language/Fixpoint/Horn/Types.hs view
@@ -1,40 +1,40 @@  ---------------------------------------------------------------------------------- | This module formalizes the key datatypes needed to represent Horn NNF+-- | This module formalizes the key datatypes needed to represent Horn NNF  --   constraints as described in "Local Refinement Typing", ICFP 2017 -------------------------------------------------------------------------------  {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleInstances #-} -module Language.Fixpoint.Horn.Types+module Language.Fixpoint.Horn.Types    ( -- * Horn Constraints and their components     Query (..)   , Cstr  (..)   , Pred  (..)   , Bind  (..)-  , Var   (..)+  , Var   (..)       -- * Raw Query   , Tag (..)   , TagVar-  , TagQuery+  , TagQuery       -- * accessing constraint labels   , cLabel -    -- * invariants (refinements) on constraints-  , okCstr+    -- * invariants (refinements) on constraints +  , okCstr +  , dummyBind -    -- * extract qualifiers+    -- * extract qualifiers    , quals--  )-  where+  ) +  where   import           Data.Generics             (Data) import           Data.Typeable             (Typeable)@@ -48,39 +48,36 @@ import qualified Text.PrettyPrint.HughesPJ.Compat as P import qualified Data.HashMap.Strict as M import           Data.Aeson-import           Data.Aeson.Types  ---------------------------------------------------------------------------------- | @HVar@ is a Horn variable+-- | @HVar@ is a Horn variable  ------------------------------------------------------------------------------- data Var a = HVar   { hvName :: !F.Symbol                         -- ^ name of the variable $k1, $k2 etc.   , hvArgs :: ![F.Sort] {- len hvArgs > 0 -}    -- ^ sorts of its parameters i.e. of the relation defined by the @HVar@   , hvMeta :: a                                 -- ^ meta-data   }-  deriving (Eq, Ord, Data, Typeable, Generic, Functor, ToJSON, FromJSON)--+  deriving (Eq, Ord, Data, Typeable, Generic, Functor)  ---------------------------------------------------------------------------------- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints+-- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints  --------------------------------------------------------------------------------data Pred-  = Reft  !F.Expr                               -- ^ r-  | Var   !F.Symbol ![F.Expr]                   -- ^ $k(y1..yn)-  | PAnd  ![Pred]                               -- ^ p1 /\ .../\ pn-  deriving (Data, Typeable, Generic, Eq, ToJSON, FromJSON)+data Pred +  = Reft  !F.Expr                               -- ^ r +  | Var   !F.Symbol ![F.Symbol]                 -- ^ $k(y1..yn) +  | PAnd  ![Pred]                               -- ^ p1 /\ .../\ pn +  deriving (Data, Typeable, Generic, Eq) -instance F.ToHornSMT (Var a) where-  toHornSMT (HVar k ts _) = P.parens ("var" P.<+> "$" P.<-> F.pprint k P.<+> F.toHornSMT ts)-instance F.ToHornSMT Pred where-  toHornSMT (Reft p)   = P.parens (F.toHornSMT p)-  toHornSMT (Var k xs) = F.toHornMany (F.toHornSMT (F.KV k) : (F.toHornSMT <$> xs))-  toHornSMT (PAnd ps)  = F.toHornMany ("and" : (F.toHornSMT <$> ps)) +instance Semigroup Pred where+  p1 <> p2 = PAnd [p1, p2]++instance Monoid Pred where +  mempty = Reft mempty+ instance F.Subable Pred where   syms (Reft e)   = F.syms e-  syms (Var _ xs) = concatMap F.syms xs+  syms (Var _ xs) = xs   syms (PAnd ps)  = concatMap F.syms ps    substa f (Reft e)   = Reft  (F.substa f      e)@@ -100,20 +97,21 @@   subst1 (Var k xs) su = Var k [F.subst1 x su | x <- xs]  --------------------------------------------------------------------------------quals :: Cstr a -> [F.Qualifier]+quals :: Cstr a -> [F.Qualifier]  --------------------------------------------------------------------------------quals = F.notracepp "horn.quals" . cstrQuals F.emptySEnv F.vv_+quals = F.tracepp "horn.quals" . cstrQuals F.emptySEnv F.vv_   -cstrQuals :: F.SEnv F.Sort -> F.Symbol -> Cstr a -> [F.Qualifier]-cstrQuals = go+cstrQuals :: F.SEnv F.Sort -> F.Symbol -> Cstr a -> [F.Qualifier] +cstrQuals = go    where     go env v (Head p _)  = predQuals env v p     go env v (CAnd   cs) = concatMap (go env v) cs-    go env _ (All  b c)  = bindQuals env b c+    go env _ (All  b c)  = bindQuals env b c +    go env _ (Any  b c)  = bindQuals env b c -bindQuals  :: F.SEnv F.Sort -> Bind a -> Cstr a -> [F.Qualifier]-bindQuals env b c = predQuals env' bx (bPred b) ++ cstrQuals env' bx c-  where+bindQuals  :: F.SEnv F.Sort -> Bind -> Cstr a -> [F.Qualifier] +bindQuals env b c = predQuals env' bx (bPred b) ++ cstrQuals env' bx c +  where      env'          = F.insertSEnv bx bt env     bx            = bSym b     bt            = bSort b@@ -121,24 +119,24 @@ predQuals :: F.SEnv F.Sort -> F.Symbol -> Pred -> [F.Qualifier] predQuals env v (Reft p)  = exprQuals env v p predQuals env v (PAnd ps) = concatMap (predQuals env v) ps-predQuals _   _ _         = []+predQuals _   _ _         = []   exprQuals :: F.SEnv F.Sort -> F.Symbol -> F.Expr -> [F.Qualifier] exprQuals env v e = mkQual env v <$> F.conjuncts e  mkQual :: F.SEnv F.Sort -> F.Symbol -> F.Expr -> F.Qualifier mkQual env v p = case envSort env <$> (v:xs) of-                   (_,so):xts -> F.mkQ "Auto" ((v, so) : xts) p junk+                   (_,so):xts -> F.mkQ "Auto" ((v, so) : xts) p junk                     _          -> F.panic "impossible"   where-    xs         = L.delete v $ Misc.setNub (F.syms p)-    junk       = F.dummyPos "mkQual"+    xs         = L.delete v $ Misc.hashNub (F.syms p)+    junk       = F.dummyPos "mkQual"   envSort :: F.SEnv F.Sort -> F.Symbol -> (F.Symbol, F.Sort) envSort env x = case F.lookupSEnv x env of-                   Just t -> (x, t)+                   Just t -> (x, t)                     _      -> F.panic $ "unbound symbol in scrape: " ++ F.showpp x-{-+{-    | Just _ <- lookupSEnv x lEnv = Nothing   | otherwise                   = Just (x, ai)   where@@ -148,42 +146,32 @@   ----------------------------------------------------------------------------------- | @Cst@ is an NNF Horn Constraint.+-- | @Cst@ is an NNF Horn Constraint.  ------------------------------------------------------------------------------- -- Note that a @Bind@ is a simplified @F.SortedReft@ ...-data Bind a = Bind-  { bSym  :: !F.Symbol-  , bSort :: !F.Sort-  , bPred :: !Pred-  , bMeta :: !a+data Bind = Bind +  { bSym  :: !F.Symbol +  , bSort :: !F.Sort +  , bPred :: !Pred    }-  deriving (Data, Typeable, Generic, Functor, Eq, ToJSON, FromJSON)+  deriving (Data, Typeable, Generic, Eq) -instance F.ToHornSMT (Bind a) where-  toHornSMT (Bind x t p _) = P.parens (F.toHornSMT (x, t) P.<+> F.toHornSMT p)+instance F.Subable Bind where+    syms = undefined+    substa = undefined+    substf = undefined+    subst su (Bind x t p) = (Bind x t (F.subst su p)) -instance F.Subable (Bind a) where-    syms     (Bind x _ p _) = x : F.syms p-    substa f (Bind v t p a) = Bind (f v) t (F.substa f p) a-    substf f (Bind v t p a) = Bind v t (F.substf (F.substfExcept f [v]) p) a-    subst su (Bind v t p a)  = Bind v t (F.subst (F.substExcept su [v]) p) a-    subst1 (Bind v t p a) su = Bind v t (F.subst1Except [v] p su) a+dummyBind :: Bind +dummyBind = Bind F.dummySymbol F.intSort (PAnd [])   -- Can we enforce the invariant that CAnd has len > 1? data Cstr a-  = Head  !Pred !a                  -- ^ p-  | CAnd  ![Cstr a]                 -- ^ c1 /\ ... /\ cn-  | All   !(Bind a)  !(Cstr a)      -- ^ \all x:t. p => c-  deriving (Data, Typeable, Generic, Functor, Eq, ToJSON, FromJSON)--instance F.ToHornSMT (Cstr a) where-  toHornSMT = toHornCstr--toHornCstr :: Cstr a -> P.Doc-toHornCstr (Head p _) = F.toHornSMT p-toHornCstr (CAnd cs)  = F.toHornAnd toHornCstr cs-toHornCstr (All b c)  = P.parens (P.vcat ["forall" P.<+> F.toHornSMT b-                                         , P.nest 1 (toHornCstr c)])+  = Head  !Pred a               -- ^ p+  | CAnd  ![(Cstr a)]           -- ^ c1 /\ ... /\ cn+  | All   !Bind  !(Cstr a)      -- ^ \all x:t. p => c+  | Any   !Bind  !(Cstr a)      -- ^ \exi x:t. p /\ c or is it \exi x:t. p => c?+  deriving (Data, Typeable, Generic, Functor, Eq)  cLabel :: Cstr a -> a cLabel cstr = case go cstr of@@ -193,40 +181,36 @@     go (Head _ l)   = [l]     go (CAnd cs)    = mconcat $ go <$> cs     go (All _ c)    = go c+    go (Any _ c)    = go c  -- We want all valid constraints to start with a binding at the top--okCstr :: Cstr a -> Bool-okCstr All {} = True-okCstr _      = False-+okCstr :: Cstr a -> Bool +okCstr (All {}) = True +okCstr (Any {}) = True +okCstr _        = False   ---------------------------------------------------------------------------------- | @Query@ is an NNF Horn Constraint.+-- | @Query@ is an NNF Horn Constraint.  ------------------------------------------------------------------------------- -data Query a = Query-  { qQuals :: ![F.Qualifier]             -- ^ qualifiers over which to solve cstrs-  , qVars  :: ![Var a]                   -- ^ kvars, with parameter-sorts-  , qCstr  :: !(Cstr a)                  -- ^ list of constraints-  , qCon   :: M.HashMap F.Symbol F.Sort  -- ^ list of constants (un/interpreted functions)-  , qDis   :: M.HashMap F.Symbol F.Sort  -- ^ list of *distinct* constants (uninterpreted functions)-  , qEqns  :: ![F.Equation]              -- ^ list of equations-  , qDefs  :: ![F.Equation]              -- ^ list of equations to be sent to SMT as define-fun-  , qMats  :: ![F.Rewrite]               -- ^ list of match-es-  , qData  :: ![F.DataDecl]              -- ^ list of data-declarations-  , qOpts  :: ![String]                  -- ^ list of fixpoint options-  , qNums  :: ![F.Symbol]                -- ^ list of numeric TyCon (?)-  , qKuts  :: ![F.KVar]                  -- ^ list of cut variables+data Query a = Query +  { qQuals :: ![F.Qualifier]                    -- ^ qualifiers over which to solve cstrs+  , qVars  :: ![Var a]                          -- ^ kvars, with parameter-sorts+  , qCstr  :: !(Cstr a)                         -- ^ list of constraints+  , qCon   :: M.HashMap (F.Symbol) (F.Sort)     -- ^ list of constants (uninterpreted functions+  , qDis   :: M.HashMap (F.Symbol) (F.Sort)     -- ^ list of constants (uninterpreted functions+  , qEqns  :: ![F.Equation]                     -- ^ list of equations+  , qMats  :: ![F.Rewrite]                      -- ^ list of match-es+  , qData  :: ![F.DataDecl]                     -- ^ list of data-declarations   }-  deriving (Data, Typeable, Generic, Functor, ToJSON, FromJSON)+  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)+  deriving (Data, Typeable, Generic, Show)   instance NFData Tag @@ -234,61 +218,45 @@   srcSpan _ = F.dummySpan  instance F.Fixpoint Tag where-  toFix NoTag   = "\"\""+  toFix NoTag   = "\"\""    toFix (Tag s) = "\"" <> P.text s <> "\""-+   instance F.PPrint Tag where   pprintPrec _ _ NoTag   = mempty-  pprintPrec _ _ (Tag s) = P.ptext s+  pprintPrec _ _ (Tag s) = P.ptext s   instance ToJSON Tag where   toJSON NoTag   = Null-  toJSON (Tag s) = String (T.pack s)--instance FromJSON Tag where-  parseJSON Null       = pure NoTag-  parseJSON (String t) = pure (Tag (T.unpack t))-  parseJSON invalid    = prependFailure "parsing `Tag` failed, " (typeMismatch "Object" invalid)--instance F.ToHornSMT Tag where-  toHornSMT NoTag   = mempty-  toHornSMT (Tag s) = P.text s--+  toJSON (Tag s) = String (T.pack s)  -instance F.PPrint (Query a) where-  pprintPrec prec t q = P.vcat $ L.intersperse " "+instance F.PPrint (Query a) where +  pprintPrec k t q = P.vcat $ L.intersperse " "      [ P.vcat   (ppQual <$> qQuals q)     , P.vcat   [ppVar k   | k <- qVars q]-    , P.vcat   [ppCon x (F.pprint sort') | (x, sort') <- M.toList (qCon 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 (prec+2) t (qCstr 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+  where +    prefix      = fromMaybe "" pfx  -ppCon :: F.Symbol -> P.Doc -> P.Doc-ppCon x td = P.parens ("constant" P.<+> F.pprint x P.<+> P.parens td)+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    = P.parens $ F.pprint (F.qpSym qp) P.<+> P.parens (F.pprint (F.qpSort qp))+  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))-+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 -------------------------------------------------------------------------------@@ -300,23 +268,24 @@  instance Show Pred where   show (Reft p)   = parens $ F.showpp p-  show (Var x xs) = parens $ "$" ++ unwords (F.symbolString x : (parens . F.showpp <$> xs))+  show (Var x xs) = parens $ unwords (F.symbolString <$> x:xs)   show (PAnd ps)  = parens $ unwords $ "and": map show ps  instance Show (Cstr a) where   show (Head p _) = parens $ show p   show (All b c)  = parens $ unwords ["forall" , show b , show c]+  show (Any b c)  = parens $ unwords ["exists" , show b , show c]   show (CAnd cs)  = parens $ unwords $ "and" : map show cs -instance Show (Bind a) where-  show (Bind x t p _) = parens $ unwords [parens $ unwords [F.symbolString x, F.showpp t], show p]+instance Show Bind where+  show (Bind x t p) = parens $ unwords [parens $ unwords [F.symbolString x, F.showpp t], show p]  instance F.PPrint (Var a) where   pprintPrec _ _ v = P.ptext $ show v  instance F.PPrint Pred where   pprintPrec k t (Reft p)   = P.parens $ F.pprintPrec k t p-  pprintPrec k t (Var x xs) = P.parens $ P.ptext "$" <> P.hsep (P.ptext (F.symbolString x) : (P.parens. F.pprintPrec k t <$> xs))+  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  instance F.PPrint (Cstr a) where@@ -324,25 +293,10 @@   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 a) where+instance F.PPrint Bind where   pprintPrec _ _ b = P.ptext $ show b--instance F.ToHornSMT (Query a) where-  toHornSMT q = P.vcat $ L.intersperse " "-    [ P.vcat   (toHornOpt <$> qOpts q)-    , P.vcat   (toHornNum <$> qNums q)-    , P.vcat   (F.toHornSMT <$> qQuals q)-    , P.vcat   (F.toHornSMT <$> qVars q)-    , P.vcat   [toHornCon x t | (x, t) <- M.toList (qCon q)]-    , P.vcat   (F.eqnToHornSMT "define"     <$> qEqns q)-    , P.vcat   (F.eqnToHornSMT "define_fun" <$> qDefs q)-    , P.vcat   (F.toHornSMT <$> qData q)-    , P.vcat   (F.toHornSMT <$> qMats q)-    , P.parens (P.vcat ["constraint", P.nest 1 (F.toHornSMT (qCstr q))])-    ]-    where-      toHornNum x   = F.toHornMany ["numeric", F.toHornSMT x]-      toHornOpt str = F.toHornMany ["fixpoint", P.text ("\"" ++ str ++ "\"")]-      toHornCon x t = F.toHornMany ["constant", F.toHornSMT x, F.toHornSMT t]
src/Language/Fixpoint/Minimize.hs view
@@ -9,7 +9,6 @@  module Language.Fixpoint.Minimize ( minQuery, minQuals, minKvars ) where -import Prelude hiding (min, init) import qualified Data.HashMap.Strict                as M import           Control.Monad                      (filterM) import           Language.Fixpoint.Types.Visitor    (mapKVars)@@ -17,15 +16,10 @@ import           Language.Fixpoint.Misc             (safeHead) import           Language.Fixpoint.Utils.Files      hiding (Result) import           Language.Fixpoint.Graph-import           Language.Fixpoint.Types            hiding (fi)+import           Language.Fixpoint.Types import           Control.DeepSeq  ------------------------------------------------------------------------------ | Top level Solvers ---------------------------------------------------------------------------------------------------------------------------------type Solver a = Config -> FInfo a -> IO (Result (Integer, a))----------------------------------------------------------------------------- -- polymorphic delta debugging implementation --------------------------------------------------------------------------- deltaDebug :: Bool -> Oracle a c -> Config -> Solver a -> FInfo a -> [c] -> [c] -> IO [c]@@ -85,7 +79,7 @@   failFis  <- filterM (fmap (not . isSafe) . solve cfg') fis   let failFi = safeHead "--minimize can only be called on UNSAT fq" failFis   let format _ cs = "Minimized Constraints: " ++ show (fst <$> cs)-  let update fi' cs = fi' { cm = M.fromList cs }+  let update fi cs = fi { cm = M.fromList cs }   commonDebug (M.toList . cm) update (not . isSafe) True cfg' solve failFi Min format  ---------------------------------------------------------------------------@@ -94,9 +88,9 @@ --------------------------------------------------------------------------- minQuals cfg solve fi = do   let cfg'  = cfg { minimizeQs = False }-  let format fi' qs = "Required Qualifiers: " ++ show (length qs)-                  ++ "; Total Qualifiers: "  ++ show (length $ quals fi')-  let update fi' qs = fi' { quals = qs }+  let format fi qs = "Required Qualifiers: " ++ show (length qs)+                  ++ "; Total Qualifiers: "  ++ show (length $ quals fi)+  let update fi qs = fi { quals = qs }   commonDebug quals update isSafe False cfg' solve fi MinQuals format  ---------------------------------------------------------------------------@@ -105,8 +99,8 @@ --------------------------------------------------------------------------- minKvars cfg solve fi = do   let cfg'  = cfg { minimizeKs = False }-  let format fi' ks = "Required KVars: " ++ show (length ks)-                  ++ "; Total KVars: "  ++ show (length $ ws fi')+  let format fi ks = "Required KVars: " ++ show (length ks)+                  ++ "; Total KVars: "  ++ show (length $ ws fi)   commonDebug (M.keys . ws) removeOtherKs isSafe False cfg' solve fi MinKVars format  removeOtherKs :: FInfo a -> [KVar] -> FInfo a
src/Language/Fixpoint/Misc.hs view
@@ -5,9 +5,9 @@ {-# LANGUAGE TupleSections             #-} {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE BangPatterns              #-} {-# LANGUAGE ImplicitParams            #-} -- ignore hlint - module Language.Fixpoint.Misc where  -- import           System.IO.Unsafe            (unsafePerformIO)@@ -19,8 +19,6 @@ import qualified Data.HashMap.Strict              as M import qualified Data.List                        as L import qualified Data.HashSet                     as S-import qualified Data.Map                         as Map-import qualified Data.Set                         as Set import           Data.Tuple                       (swap) import           Data.Maybe import           Data.Array                       hiding (indices)@@ -31,7 +29,7 @@ import           Data.Unique import           Debug.Trace                      (trace) import           System.Console.ANSI-import           Language.Fixpoint.Verbosity (whenLoud)+import           System.Console.CmdArgs.Verbosity (whenLoud) import           System.Process                   (system) import           System.Directory                 (createDirectoryIfMissing) import           System.FilePath                  (takeDirectory)@@ -43,10 +41,6 @@ import Prelude hiding (undefined) import GHC.Stack -infixl 9 ==>-(==>) :: Bool -> Bool -> Bool-p ==> q = not p || q- type (|->) a b = M.HashMap a b  firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b@@ -62,14 +56,14 @@ hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)] hashMapToAscList = L.sortBy (compare `on` fst) . M.toList -findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a+findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a  findNearest key kvs = argMin [ (abs (key - k), v) | (k, v) <- kvs ] -argMin :: (Ord k) => [(k, v)] -> Maybe v+argMin :: (Ord k) => [(k, v)] -> Maybe v  argMin = fmap snd . headMb . L.sortBy (compare `on` fst) -headMb :: [a] -> Maybe a-headMb []    = Nothing+headMb :: [a] -> Maybe a +headMb []    = Nothing  headMb (x:_) = Just x --------------------------------------------------------------- -- | Unique Int -----------------------------------------------@@ -85,9 +79,9 @@ -- | Edit Distance -------------------------------------------- --------------------------------------------------------------- -{-# SCC levenshteinDistance #-}-levenshteinDistance :: Eq a => [a] -> [a] -> Int-levenshteinDistance xs ys = table ! (m, n)+{-# SCC editDistance #-}+editDistance :: Eq a => [a] -> [a] -> Int+editDistance xs ys = table ! (m, n)     where     (m,n) = (length xs, length ys)     x     = array (1,m) (zip [1..] xs)@@ -156,7 +150,7 @@   errorP :: String -> String -> a-errorP p s = error (p ++ s)+errorP p s = error (p ++ s)     errorstar :: (?callStack :: CallStack) => String -> a errorstar  = error . wrap (stars ++ "\n") (stars ++ "\n")@@ -211,8 +205,8 @@ allMap :: (Eq k, Hashable k) => (v -> Bool) -> M.HashMap k v -> Bool allMap p = L.foldl' (\a v -> a && p v) True -setNub :: Ord k => [k] -> [k]-setNub = Set.toList . Set.fromList+hashNub :: (Eq k, Hashable k) => [k] -> [k]+hashNub = M.keys . M.fromList . fmap (, ())  sortNub :: (Ord a) => [a] -> [a] sortNub = nubOrd . L.sort@@ -226,11 +220,11 @@   | otherwise = x : nubOrd t nubOrd xs     = xs -hashNubWith :: Ord b => (a -> b) -> [a] -> [a]-hashNubWith f xs = Map.elems $ Map.fromList [ (f x, x) | x <- xs ]+hashNubWith :: (Eq b, Hashable b) => (a -> b) -> [a] -> [a]+hashNubWith f xs = M.elems $ M.fromList [ (f x, x) | x <- xs ]  mFromList :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k v-mFromList = M.fromList+mFromList = M.fromList   duplicates :: (Eq k, Hashable k) => [k] -> [k] duplicates xs = [ x | (x, n) <- count xs, 1 < n ]@@ -270,8 +264,8 @@   where     -- dups             = duplicates . fmap fst     dups             = [ x | (x, n) <- count (fst <$> kvs), 1 < n ]-    err              = errorstar . wrapMsg "safeFromList with duplicates" msg . show-    wrapMsg m1 m2 s     = m1 ++ " " ++ s ++ " " ++ m2+    err              = errorstar . wrap "safeFromList with duplicates" msg . show+    wrap m1 m2 s     = m1 ++ " " ++ s ++ " " ++ m2   safeHead _   (x:_) = x safeHead msg _     = errorstar $ "safeHead with empty list " ++ msg@@ -313,6 +307,16 @@ ensurePath :: FilePath -> IO () ensurePath = createDirectoryIfMissing True . takeDirectory +singleton :: a -> [a]+singleton x = [x]++pair :: a -> a -> [a]+pair x1 x2 = [x1, x2]++triple :: a -> a -> a -> [a]+triple x1 x2 x3 = [x1, x2, x3]++ fM :: (Monad m) => (a -> b) -> a -> m b fM f = return . f @@ -321,14 +325,23 @@   b <- cond   when b act -ifM :: (Monad m) => m Bool -> m a -> m a -> m a-ifM c t e = do-  b <- c-  if b then t else e+ifM :: (Monad m) => m Bool -> m a -> m a -> m a +ifM c t e = do +  b <- c +  if b then t else e  -dbgFalse :: Bool-dbgFalse = 1 > (2 :: Int)+mapEither :: (a -> Either b c) -> [a] -> ([b], [c])+mapEither _ []     = ([], [])+mapEither f (x:xs) = case f x of+                       Left y  -> (y:ys, zs)+                       Right z -> (ys, z:zs)+                     where+                       (ys, zs) = mapEither f xs +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _         = False+ componentsWith :: (Ord c) => (a -> [(b, c, [c])]) -> a -> [[b]] componentsWith eF x = map (fst3 . f) <$> vss   where@@ -344,8 +357,8 @@ -- | -- >>> let em = M.fromList [ (1, [2, 3]), (2, [1, 3]), (3, []   ) ] -- >>> let ef = \v -> (v, M.lookupDefault [] v em)--- >>> sccsWith ef [1,2,3]--- [[3],[1,2]]+-- >>> sccsWith ef [1,2,3]  +-- [[3],[1,2]]   sccsWith :: (Ord v) => (a -> (v, [v])) -> [a] -> [[a]] sccsWith vF xs     = map (fst3 . f) <$> (T.flatten <$> G.scc g)@@ -382,29 +395,66 @@     vus           = swap <$> uvs     uvs           = [ (u, v) | (u : vs) <- vss, v <- vs ] +{-+exitColorStrLn :: Moods -> String -> IO ()+exitColorStrLn c s = do+  writeIORef pbRef Nothing --(Just pr)+  putStrLn "\n"+  colorStrLn c s+-}++mapFst :: (a -> c) -> (a, b) -> (c, b)+mapFst f (x, y) = (f x, y)++mapSnd :: (b -> c) -> (a, b) -> (a, c)+mapSnd f (x, y) = (x, f y)++ {-@ allCombinations :: xss:[[a]] -> [{v:[a]| len v == len xss}] @-} allCombinations :: [[a]] -> [[a]]-allCombinations xs = assert (all ((length xs == ) . length)) $ go xs+allCombinations xs = assert (and . map (((length xs) == ) . length)) $ go xs   where-   go []           = [[]]-   go [[]]         = []-   go ([]:_)       = []-   go ((x:xs'):ys) = ((x:) <$> go ys) ++ go (xs':ys)+   go []          = [[]]+   go [[]]        = []+   go ([]:_)      = []+   go ((x:xs):ys) = ((x:) <$> go ys) ++ go (xs:ys)     assert b x = if b x then x else errorstar "allCombinations: assertion violation"  powerset :: [a] -> [[a]] powerset xs = filterM (const [False, True]) xs +(=>>) :: Monad m => m b -> (b -> m a) -> m b+(=>>) m f = m >>= (\x -> f x >> return x)++(<<=) :: Monad m => (b -> m a) -> m b -> m b+(<<=) = flip (=>>)++(<$$>) ::  (Monad m) => (a -> m b) -> [a] -> m [b]+_ <$$> []           = return []+f <$$> [x1]         = singleton <$> f x1+f <$$> [x1, x2]     = pair      <$> f x1 <*> f x2+f <$$> [x1, x2, x3] = triple    <$> f x1 <*> f x2 <*> f x3+f <$$> xs           = revMapM f ({- trace msg -} xs)+  where+    _msg            = "<$$> on " ++ show (length xs)++revMapM  :: (Monad m) => (a -> m b) -> [a] -> m [b]+revMapM f          = go []+  where+    go !acc []     = return (reverse acc)+    go !acc (x:xs) = do {!y <- f x; go (y:acc) xs}+ -- Null if first is a subset of second-nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a+nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a  nubDiff a b = a' `S.difference` b'   where     a' = S.fromList a     b' = S.fromList b  -fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a-fold1M _ []         = errorstar "fold1M with empty list"-fold1M _ [x]        = return x-fold1M f (x1:x2:xs) = do { x <- f x1 x2; fold1M f (x:xs) }+fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a +fold1M _ []         = errorstar $ "fold1M with empty list"+fold1M _ [x]        = return x +fold1M f (x1:x2:xs) = do { x <- f x1 x2; fold1M f (x:xs) }  +
src/Language/Fixpoint/Parse.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE DeriveGeneric             #-} {-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE ScopedTypeVariables       #-}  module Language.Fixpoint.Parse ( @@ -13,12 +14,9 @@    -- * Top Level Class for Parseable Values   , Parser-  , ParserV-  , ParseableV (..)    -- * Some Important keyword and parsers   , reserved, reservedOp-  , reserved', reservedOp'   , locReserved   , parens  , brackets, angles, braces   , semi    , comma@@ -26,43 +24,37 @@   , dot   , pairP   , stringLiteral-  , stringR   , locStringLiteral-  , sym    -- * Parsing basic entities    --   fTyConP  -- Type constructors-  , lowerIdP-  , lowerIdR    -- Lower-case identifiers-  , upperIdP-  , upperIdR    -- Upper-case identifiers-  , symbolP-  , symbolR     -- Arbitrary Symbols+  , lowerIdP    -- Lower-case identifiers+  , upperIdP    -- Upper-case identifiers+  -- , infixIdP    -- String Haskell infix Id+  , symbolP     -- Arbitrary Symbols   , locSymbolP   , constantP   -- (Integer) Constants-  , natural-  , naturalR    -- Non-negative integer+  , natural     -- Non-negative integer   , locNatural   , bindP       -- Binder (lowerIdP <* colon)   , sortP       -- Sort   , mkQual      -- constructing qualifiers   , infixSymbolP -- parse infix symbols   , locInfixSymbolP-  , kvarP    -- * 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-  , defineP      -- function definition equations (PLE)-  , defineLocalP -- local function definition equations (PLE)-  , matchP       -- measure definition equations (PLE)+  , 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@@ -79,10 +71,8 @@   , condIdR    -- * Lexemes and lexemes with location-  , lexeme'   , lexeme   , located-  , locLexeme'   , locLexeme   , locLowerIdP   , locUpperIdP@@ -92,7 +82,6 @@    -- * Parsing Function   , doParse'-  , doParse''   , parseTest'   , parseFromFile   , parseFromStdIn@@ -102,29 +91,24 @@   , isSmall   , isNotReserved -  , initPState, PState, PStateV (..)+  , initPState, PState (..)    , LayoutStack(..)-  , Fixity(..), Assoc(..), addOperatorP, addNumTyCon+  , Fixity(..), Assoc(..), addOperatorP    -- * For testing   , expr0P   , dataFieldP   , dataCtorP   , dataDeclP-  , fTyConP-  , mkFTycon-  , intP-  , tvarP-  , trueP, falseP, symconstP+   ) where -import           Control.Monad (unless, void) 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 qualified Data.List                   as List+import           Data.List                   (foldl') import           Data.List.NonEmpty          (NonEmpty(..)) import qualified Data.Text                   as T import qualified Data.Text.IO                as T@@ -136,11 +120,11 @@ 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, fi, GInfo(..))-import qualified Language.Fixpoint.Types     as Types (GInfo(FI))+import           Language.Fixpoint.Types hiding    (mapSort) import           Text.PrettyPrint.HughesPJ         (text, vcat, (<+>), Doc)  import Control.Monad.State@@ -201,8 +185,7 @@ -- Note that this is in deviation from what the old LH parser did, -- but I think that was plainly wrong. -type Parser = ParserV Symbol-type ParserV v = StateT (PStateV v) (Parsec Void String)+type Parser = StateT PState (Parsec Void String)  -- | The parser state. --@@ -217,22 +200,13 @@ -- -- Finally, we keep track of the layout stack. ---data PStateV v = PState { fixityTable :: OpTable v-                     , fixityOps   :: [Fixity v]-                      -- | An expression to use whenever an empty list is parsed (@[]@)-                      ---                      -- Receives the location of the empty list-                     , empList     :: Maybe (Located () -> ExprV v)-                      -- | An expression to use whenever a singleton list is parsed (@[e]@)-                      ---                      -- Receives the location of the singleton list and the inner expression-                     , singList    :: Maybe (Located () -> ExprV v -> ExprV v)+data PState = PState { fixityTable :: OpTable+                     , fixityOps   :: [Fixity]+                     , empList     :: Maybe Expr+                     , singList    :: Maybe (Expr -> Expr)                      , supply      :: !Integer                      , layoutStack :: LayoutStack-                     , numTyCons   :: !(S.HashSet Symbol)-                     , allowExists :: !Bool                      }-type PState = PStateV Symbol  -- | The layout stack tracks columns at which layout blocks -- have started.@@ -252,12 +226,12 @@ popLayoutStack (After _ s) = s  -- | Modify the layout stack using the given function.-modifyLayoutStack :: (LayoutStack -> LayoutStack) -> ParserV v ()+modifyLayoutStack :: (LayoutStack -> LayoutStack) -> Parser () modifyLayoutStack f =   modify (\ s -> s { layoutStack = f (layoutStack s) })  -- | Start a new layout block at the current indentation level.-setLayout :: ParserV v ()+setLayout :: Parser () setLayout = do   i <- L.indentLevel   -- traceShow ("setLayout", i) $ pure ()@@ -266,13 +240,13 @@ -- | Temporarily reset the layout information, because we enter -- a block with explicit separators. ---resetLayout :: ParserV v ()+resetLayout :: Parser () resetLayout = do   -- traceShow ("resetLayout") $ pure ()   modifyLayoutStack Reset  -- | Remove the topmost element from the layout stack.-popLayout :: ParserV v ()+popLayout :: Parser () popLayout = do   -- traceShow ("popLayout") $ pure ()   modifyLayoutStack popLayoutStack@@ -284,7 +258,7 @@ -- The only "valid" use case for spaces is in top-level parsing -- function, to consume initial spaces. ---spaces :: ParserV v ()+spaces :: Parser () spaces =   L.space     space1@@ -297,7 +271,7 @@ -- This is a variant of 'indentGuard' provided by megaparsec, -- only that it does not consume whitespace. ---guardIndentLevel :: Ordering -> Pos -> ParserV v ()+guardIndentLevel :: Ordering -> Pos -> Parser () guardIndentLevel ord ref = do   actual <- L.indentLevel   -- traceShow ("guardIndentLevel", actual, ord, ref) $ pure ()@@ -312,7 +286,7 @@ -- to check whether the next token is valid within the current -- block. ---guardLayout :: ParserV v (ParserV v ())+guardLayout :: Parser (Parser ()) guardLayout = do   stack <- gets layoutStack   -- traceShow ("guardLayout", stack) $ pure ()@@ -333,7 +307,7 @@ -- a new, nested, layout block, which should be indented further -- than the surrounding blocks. ---strictGuardLayout :: ParserV v ()+strictGuardLayout :: Parser () strictGuardLayout = do   stack <- gets layoutStack   -- traceShow ("strictGuardLayout", stack) $ pure ()@@ -347,13 +321,10 @@ -- whether we are in a position permitted by the layout stack. -- After the token, consume whitespace and potentially change state. ---lexeme' :: ParserV v () -> ParserV v a -> ParserV v a-lexeme' spacesP p = do+lexeme :: Parser a -> Parser a+lexeme p = do   after <- guardLayout-  p <* spacesP <* after--lexeme :: ParserV v a -> ParserV v a-lexeme = lexeme' spaces+  p <* spaces <* after  -- | Indentation-aware located lexeme parser. --@@ -361,24 +332,21 @@ -- 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' :: ParserV v () -> ParserV v a -> ParserV v (Located a)-locLexeme' spacesP p = do+locLexeme :: Parser a -> Parser (Located a)+locLexeme p = do   after <- guardLayout   l1 <- getSourcePos   x <- p   l2 <- getSourcePos-  spacesP <* after+  spaces <* after   pure (Loc l1 l2 x) -locLexeme :: ParserV v a -> ParserV v (Located a)-locLexeme = locLexeme' spaces- -- | Make a parser location-aware. -- -- This is at the cost of an imprecise span because we still -- consume spaces in the end first. ---located :: ParserV v a -> ParserV v (Located a)+located :: Parser a -> Parser (Located a) located p = do   l1 <- getSourcePos   x <- p@@ -391,7 +359,7 @@ -- -- Assumes that the parser for items does not accept the empty string. ---indentedBlock :: ParserV v a -> ParserV v [a]+indentedBlock :: Parser a -> Parser [a] indentedBlock p =       strictGuardLayout *> setLayout *> many (p <* popLayout) <* popLayout       -- We have to pop after every p, because the first successful@@ -402,7 +370,7 @@       -- layout check fails, we still want to accept this as an empty block.  -- | Parse a single line that may be continued via layout.-indentedLine :: ParserV v a -> ParserV v a+indentedLine :: Parser a -> Parser a indentedLine p =   setLayout *> p <* popLayout <* popLayout   -- We have to pop twice, because the first successful token@@ -413,7 +381,7 @@ -- -- Assumes that the parser for items does not accept the empty string. ---indentedOrExplicitBlock :: ParserV v open -> ParserV v close -> ParserV v sep -> ParserV v a -> ParserV v [a]+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))@@ -421,16 +389,21 @@ -- | Parse a block of items that are delimited via explicit delimiters. -- Layout is disabled/reset for the scope of this block. ---explicitBlock :: ParserV v open -> ParserV v close -> ParserV v sep -> ParserV v a -> ParserV v [a]+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 -> ParserV v String+sym :: String -> Parser String sym x =   lexeme (string x) -semi, comma, colon, dcolon, dot :: ParserV v String+-- | 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@@ -446,14 +419,14 @@ -- end, and multiple subsequent semicolons, so the resulting parser -- provides the illusion of allowing empty items. ---block :: ParserV v a -> ParserV v [a]+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 :: ParserV v a -> ParserV v [a]+explicitCommaBlock :: Parser a -> Parser [a] explicitCommaBlock =   explicitBlock (sym "{") (sym "}") comma @@ -476,7 +449,6 @@   , "func"   , "autorewrite"   , "rewrite"-  , "lit"    -- reserved words used in liquid haskell   , "forall"@@ -499,7 +471,6 @@   , "class"   , "data"   , "define"-  , "defineLocal"   , "defined"   , "embed"   , "expression"@@ -538,7 +509,7 @@   , "->"   , ":="   , "&", "^", "<<", ">>", "--"-  , "Bexp"+  , "?", "Bexp"   , "'"   , "_|_"   , "|"@@ -554,22 +525,22 @@ -}  -- | Consumes a line comment.-lhLineComment :: ParserV v ()+lhLineComment :: Parser () lhLineComment =-  L.skipLineComment "//"+  L.skipLineComment "// "  -- | Consumes a block comment.-lhBlockComment :: ParserV v ()+lhBlockComment :: Parser () lhBlockComment =-  L.skipBlockCommentNested "/*" "*/"+  L.skipBlockComment "/* " "*/"  -- | Parser that consumes a single char within an identifier (not start of identifier).-identLetter :: ParserV v Char+identLetter :: Parser Char identLetter =   alphaNumChar <|> oneOf ("_" :: String)  -- | Parser that consumes a single char within an operator (not start of operator).-opLetter :: ParserV v Char+opLetter :: Parser Char opLetter =   oneOf (":!#$%&*+./<=>?@\\^|-~'" :: String) @@ -580,16 +551,11 @@ -- NOTE: we currently don't double-check that the reserved word is in the -- list of reserved words. ---reserved :: String -> ParserV v ()+reserved :: String -> Parser () reserved x =   void $ lexeme (try (string x <* notFollowedBy identLetter)) -reserved' :: Parser () -> String -> Parser ()-reserved' spacesP x =-  void $ lexeme' spacesP (try (string x <* notFollowedBy identLetter))---locReserved :: String -> ParserV v (Located String)+locReserved :: String -> Parser (Located String) locReserved x =   locLexeme (try (string x <* notFollowedBy identLetter)) @@ -600,15 +566,10 @@ -- NOTE: we currently don't double-check that the reserved operator is in the -- list of reserved operators. ---reservedOp :: String -> ParserV v ()+reservedOp :: String -> Parser () reservedOp x =   void $ lexeme (try (string x <* notFollowedBy opLetter)) -reservedOp' :: Parser () -> String -> Parser ()-reservedOp' spacesP x =-  void $ lexeme' spacesP (try (string x <* notFollowedBy opLetter))-- -- | Parser that consumes the given symbol. -- -- The difference with 'reservedOp' is that the given symbol is seen@@ -619,30 +580,34 @@ -- symbol x = --   L.symbol spaces (string x) -parens, brackets, angles, braces :: ParserV v a -> ParserV v a+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 :: ParserV v String+stringLiteral :: Parser String stringLiteral =   lexeme stringR <?> "string literal" -locStringLiteral :: ParserV v (Located String)+locStringLiteral :: Parser (Located String) locStringLiteral =   locLexeme stringR <?> "string literal" -stringR :: ParserV v String+stringR :: Parser String stringR =   char '\"' *> manyTill L.charLiteral (char '\"')  -- | Consumes a float literal lexeme.-double :: ParserV v Double+double :: Parser Double double = lexeme L.float <?> "float literal"  -- identifier :: Parser String@@ -654,15 +619,15 @@ -- This does not parse negative integers. Unary minus is available -- as an operator in the expression language. ---natural :: ParserV v Integer+natural :: Parser Integer natural =   lexeme naturalR <?> "nat literal" -locNatural :: ParserV v (Located Integer)+locNatural :: Parser (Located Integer) locNatural =   locLexeme naturalR <?> "nat literal" -naturalR :: ParserV v Integer+naturalR :: Parser Integer naturalR =       try (char '0' *> char' 'x') *> L.hexadecimal   <|> try (char '0' *> char' 'o') *> L.octal@@ -677,8 +642,8 @@ -- * a check for the entire identifier to be applied in the end, -- * an error message to display if the final check fails. ---condIdR :: ParserV v Char -> (Char -> Bool) -> (String -> Bool) -> String -> ParserV v Symbol-condIdR initial okChars condition msg = try $ do+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)@@ -690,7 +655,7 @@ -- -- See Note [symChars]. ---upperIdR :: ParserV v Symbol+upperIdR :: Parser Symbol upperIdR =   condIdR upperChar (`S.member` symChars) (const True) "unexpected" @@ -698,7 +663,7 @@ -- -- See Note [symChars]. ---lowerIdR :: ParserV v Symbol+lowerIdR :: Parser Symbol lowerIdR =   condIdR (lowerChar <|> char '_') (`S.member` symChars) isNotReserved "unexpected reserved word" @@ -706,7 +671,7 @@ -- -- See Note [symChars]. ---symbolR :: ParserV v Symbol+symbolR :: Parser Symbol symbolR =   condIdR (letterChar <|> char '_') (`S.member` symChars) isNotReserved "unexpected reserved word" @@ -733,13 +698,13 @@  -- | Lexeme version of 'upperIdR'. ---upperIdP :: ParserV v Symbol+upperIdP :: Parser Symbol upperIdP  =   lexeme upperIdR <?> "upperIdP"  -- | Lexeme version of 'lowerIdR'. ---lowerIdP :: ParserV v Symbol+lowerIdP :: Parser Symbol lowerIdP  =   lexeme lowerIdR <?> "lowerIdP" @@ -749,150 +714,166 @@ -- -- Lexeme version of 'symbolR'. ---symbolP :: ParserV v Symbol+symbolP :: Parser Symbol symbolP =   lexeme symbolR <?> "identifier"  -- The following are located versions of the lexeme identifier parsers. -locSymbolP, locLowerIdP, locUpperIdP :: ParserV v LocSymbol+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 :: ParserV v Constant+constantP :: Parser Constant constantP =      try (R <$> double)   -- float literal  <|> I <$> natural        -- nat literal  -- | Parser for literal string contants.-symconstP :: ParserV v SymConst+symconstP :: Parser SymConst symconstP = SL . T.pack <$> stringLiteral --- | A class to parse symbols------ liquid-fixpoint parses Symbol and LiquidHaskell instantiates this to--- LocSymbol for more precise error messages. If liquid-fixpoint is adapted to--- parse names as LocSymbol as well, this class can be eliminated.-class (Fixpoint v, Ord v) => ParseableV v where-  parseV :: ParserV v v-  mkSu :: [(Symbol, ExprV v)] -> KVarSubst Symbol v-  vFromString :: Located String -> v--instance ParseableV Symbol where-  parseV = symbolP-  mkSu = mkKVarSubst-  vFromString = symbol- -- | Parser for "atomic" expressions. -- -- This parser is reused by Liquid Haskell. ---expr0P :: ParseableV v => ParserV v (ExprV v)-expr0P =-        botP-    <|> try (reserved "not") *> fmap PNot appliableExprP -- built-in prefix not-    <|> funAppP-    <|> existP-    <|> fastIfP EIte exprP -- "if-then-else", starts with "if"-    <|> try (coerceP exprP) -- coercion, starts with "coerce"-    <|> litP-    <|> lamP -- lambda abstraction, starts with backslash-    <|> (reservedOp "&&" >> PAnd <$> predsP) -- built-in prefix and-    <|> (reservedOp "||" >> POr  <$> predsP) -- built-in prefix or+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 :: Located () -> ParserV v (ExprV v)-emptyListP lx = do-  e <- gets empList+emptyListP :: Parser Expr+emptyListP = do+  e <- empList <$> get   case e of     Nothing -> fail "No parsing support for empty lists"-    Just s  -> return $ s lx+    Just s  -> return s -singletonListP :: Located (ExprV v) -> ParserV v (ExprV v)+singletonListP :: Expr -> Parser Expr singletonListP e = do-  f <- gets singList+  f <- singList <$> get   case f of     Nothing -> fail "No parsing support for singleton lists"-    Just s  -> return $ s (void e) (val e)+    Just s  -> return $ s e  -- | Parser for an explicitly type-annotated expression.-exprCastP :: ParseableV v => ParserV v (ExprV v)+exprCastP :: Parser Expr exprCastP   = do e  <- exprP-       _ <- try dcolon <|> colon -- allow : or :: *and* allow following symbols-       ECst e <$> sortP+       try dcolon <|> colon -- allow : or :: *and* allow following symbols+       so <- sortP+       return $ ECst e so -fastIfP :: ParseableV v => (ExprV v -> a -> a -> a) -> ParserV v a -> ParserV v a+fastIfP :: (Expr -> a -> a -> a) -> Parser a -> Parser a fastIfP f bodyP   = do reserved "if"-       p <- exprP+       p <- predP        reserved "then"        b1 <- bodyP        reserved "else"-       f p b1 <$> bodyP+       b2 <- bodyP+       return $ f p b1 b2 -coerceP :: ParserV v (ExprV v) -> ParserV v (ExprV v)+coerceP :: Parser Expr -> Parser Expr coerceP p = do   reserved "coerce"   (s, t) <- parens (pairP sortP (reservedOp "~") sortP)-  ECoerc s t <$> p+  e      <- p+  return $ ECoerc s t e --- | Expressions -exprP :: ParseableV v => ParserV v (ExprV v)-exprP = do++{-+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 expr0P (flattenOpTable table)+    makeExprParser expr1P (flattenOpTable table)  data Assoc = AssocNone | AssocLeft | AssocRight -data Fixity v-  = FInfix   {fpred :: Maybe Int, fname :: String, fop2 :: Maybe (Located String -> ExprV v -> ExprV v -> ExprV v), fassoc :: Assoc}-  | FPrefix  {fpred :: Maybe Int, fname :: String, fop1 :: Maybe (Located String -> ExprV v -> ExprV v)}-  | FPostfix {fpred :: Maybe Int, fname :: String, fop1 :: Maybe (Located String -> ExprV v -> ExprV v)}+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 v = IM.IntMap [Operator (ParserV v) (ExprV v)] -- [[Operator Parser Expr]]+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 v -> [[Operator (ParserV v) (ExprV v)]]+flattenOpTable :: OpTable -> [[Operator Parser Expr]] flattenOpTable =   (snd <$>) <$> IM.toDescList  -- | Add an operator to the parsing state.-addOperatorP :: ParseableV v => Fixity v -> ParserV v ()+addOperatorP :: Fixity -> Parser () addOperatorP op   = modify $ \s -> s{ fixityTable = addOperator op (fixityTable s)                     , fixityOps   = op:fixityOps s                     } --- | Add a new numeric FTyCon (symbol) to the parsing state.-addNumTyCon :: Symbol -> Parser ()-addNumTyCon tc = modify $ \s -> s{ numTyCons = S.insert tc (numTyCons s) }- -- | Parses any of the known infix operators. infixSymbolP :: Parser Symbol infixSymbolP = do-  ops <- gets infixOps-  choice (resX <$> ops)+  ops <- infixOps <$> get+  choice (reserved' <$> ops)   where     infixOps st = [s | FInfix _ s _ _ <- fixityOps st]-    resX x = reserved x >> return (symbol x)+    reserved' x = reserved x >> return (symbol x)  -- | Located version of 'infixSymbolP'.-locInfixSymbolP :: ParserV v (Located Symbol)+locInfixSymbolP :: Parser (Located Symbol) locInfixSymbolP = do-  ops <- gets infixOps-  choice (resX <$> ops)+  ops <- infixOps <$> get+  choice (reserved' <$> ops)   where     infixOps st = [s | FInfix _ s _ _ <- fixityOps st]-    resX x = locReserved x >>= \ (Loc l1 l2 _) -> return (Loc l1 l2 (symbol x))+    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@@ -900,17 +881,14 @@ mkInfix AssocRight = InfixR mkInfix AssocNone  = InfixN -locReservedOp :: String -> ParserV v (Located String)-locReservedOp s = (s <$) <$> located (reservedOp s)- -- | Add the given operator to the operator table.-addOperator :: ParseableV v => Fixity v -> OpTable v -> OpTable v+addOperator :: Fixity -> OpTable -> OpTable addOperator (FInfix p x f assoc) ops- = insertOperator (makePrec p) (mkInfix assoc (makeInfixFun f <$> locReservedOp x)) ops+ = insertOperator (makePrec p) (mkInfix assoc (reservedOp x >> return (makeInfixFun x f))) ops addOperator (FPrefix p x f) ops- = insertOperator (makePrec p) (Prefix (makePrefixFun f <$> locReservedOp x)) ops+ = insertOperator (makePrec p) (Prefix (reservedOp x >> return (makePrefixFun x f))) ops addOperator (FPostfix p x f) ops- = insertOperator (makePrec p) (Postfix (makePrefixFun f <$> locReservedOp x)) ops+ = insertOperator (makePrec p) (Postfix (reservedOp x >> return (makePrefixFun x f))) ops  -- | Helper function for computing the priority of an operator. --@@ -919,125 +897,96 @@ makePrec :: Maybe Int -> Int makePrec = fromMaybe 9 -makeInfixFun :: ParseableV v => Maybe (Located String -> ExprV v -> ExprV v -> ExprV v) -> Located String -> ExprV v -> ExprV v -> ExprV v-makeInfixFun = fromMaybe (\lx e1 e2 -> EApp (EApp (EVar $ vFromString lx) e1) e2)+makeInfixFun :: String -> Maybe (Expr -> Expr -> Expr) -> Expr -> Expr -> Expr+makeInfixFun x = fromMaybe (\e1 e2 -> EApp (EApp (EVar $ symbol x) e1) e2) -makePrefixFun :: ParseableV v => Maybe (Located String -> ExprV v -> ExprV v) -> Located String -> ExprV v -> ExprV v-makePrefixFun = fromMaybe (EApp . EVar . vFromString)+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 (ParserV v) (ExprV v) -> OpTable v -> OpTable v+insertOperator :: Int -> Operator Parser Expr -> OpTable -> OpTable insertOperator i op = IM.alter (Just . (op :) . fromMaybe []) i  -- | The initial (empty) operator table.-initOpTable :: OpTable v+initOpTable :: OpTable initOpTable = IM.empty  -- | Built-in operator table, parameterised over the composition function.-bops :: forall v. ParseableV v => Maybe (Located String -> ExprV v) -> OpTable v-bops cmpFun = List.foldl' (flip addOperator) initOpTable builtinOps+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 v]-    builtinOps = [ FPrefix (Just 9) "-"   (Just $ const ENeg)-                 , FInfix  (Just 7) "*"   (Just $ const $ EBin Times) AssocLeft-                 , FInfix  (Just 7) "/"   (Just $ const $ EBin Div)   AssocLeft-                 , FInfix  (Just 6) "-"   (Just $ const $ EBin Minus) AssocLeft-                 , FInfix  (Just 6) "+"   (Just $ const $ EBin Plus)  AssocLeft-                 , FInfix  (Just 5) "mod" (Just $ const $ EBin Mod)   AssocLeft -- Haskell gives mod 7+    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-                --  ---                 , FInfix  (Just 4) "=="  (Just $ const $ PAtom Eq)  AssocNone-                 , FInfix  (Just 4) "="   (Just $ const $ PAtom Eq)  AssocNone-                 , FInfix  (Just 4) "~~"  (Just $ const $ PAtom Ueq) AssocNone-                 , FInfix  (Just 4) "!="  (Just $ const $ PAtom Ne)  AssocNone-                 , FInfix  (Just 4) "/="  (Just $ const $ PAtom Ne)  AssocNone-                 , FInfix  (Just 4) "!~"  (Just $ const $ PAtom Une) AssocNone-                 , FInfix  (Just 4) "<"   (Just $ const $ PAtom Lt)  AssocNone-                 , FInfix  (Just 4) "<="  (Just $ const $ PAtom Le)  AssocNone-                 , FInfix  (Just 4) ">"   (Just $ const $ PAtom Gt)  AssocNone-                 , FInfix  (Just 4) ">="  (Just $ const $ PAtom Ge)  AssocNone--                 , FInfix  (Just 3) "&&"  (Just $ const $ \x y -> PAnd [x,y]) AssocRight-                 , FInfix  (Just 2) "||"  (Just $ const $ \x y -> POr [x,y]) AssocRight-                 , FInfix  (Just 1) "=>"  (Just $ const PImp) AssocRight-                 , FInfix  (Just 1) "==>" (Just $ const PImp) AssocRight-                 , FInfix  (Just 1) "<=>" (Just $ const PIff) AssocRight-                 , FPrefix (Just 9) "~"   (Just $ const PNot)                  ]--    applyCompose :: Maybe (Located String -> ExprV v -> ExprV v -> ExprV v)-    applyCompose = (\f lop x y -> f lop `eApps` [x,y]) <$> cmpFun+    applyCompose :: Maybe (Expr -> Expr -> Expr)+    applyCompose = (\f x y -> (f `eApps` [x,y])) <$> cmpFun  -- | Parser for function applications.-funAppP :: ParseableV v => ParserV v (ExprV v)-funAppP = do-    f <- appliableExprP-    foldl EApp f <$> (<|>)-      (try $ parens $ brackets $ sepBy exprP semi)  -- special form: f ([e1; e2; ...; en])-      (many appliableExprP)                   -- normal function application: f e1 e2 ... en--appliableExprP :: ParseableV v => ParserV v (ExprV v)-appliableExprP =-       trueP -- constant "true"-   <|> falseP -- constant "false"-   <|> (ESym <$> symconstP) -- string literal, starts with double-quote-   <|> (ECon <$> constantP) -- numeric literal, starts with a digit-   <|> botP-   <|> 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 <$> parseV  -- identifier, starts with any letter or underscore-   <|> try (located (brackets (pure ())) >>= emptyListP) -- empty list, start with "["-   <|> try (located (brackets exprP) >>= singletonListP) -- singleton list, starts with "["-   <|> kvarPredP+--+-- 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) --- | constant bottom, equivalent to "false"-botP :: ParserV v (ExprV v)-botP = reservedOp "_|_" >> return EBot+    -- 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 :: ParseableV v => ParserV v (ExprV v)+tupleP :: Parser Expr tupleP = do-  lp <- located $ parens ((,) <$> exprP <* comma <*> sepBy1 exprP comma) -- at least two components necessary-  let (first, rest) = val lp-      cons = vFromString $ ("(" ++ replicate (length rest) ',' ++ ")") <$ lp -- stored in prefix form-  return $ eApps (EVar cons) (first : rest)+  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)  --- | Parser for literals of all sorts.-litP :: ParserV v (ExprV v)+-- 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-          ECon . L (T.pack l) <$> sortP+          t <- sortP+          return $ ECon $ L (T.pack l) t  -- | Parser for lambda abstractions.-lamP :: ParseableV v => ParserV v (ExprV v)+lamP :: Parser Expr lamP   = do reservedOp "\\"        x <- symbolP-       _ <- colon -- TODO: this should probably be reservedOp instead+       colon -- TODO: this should probably be reservedOp instead        t <- sortP        reservedOp "->"-       ELam (x, t) <$> exprP-      <?> "lambda abstraction"+       e  <- exprP+       return $ ELam (x, t) e -varSortP :: ParserV v Sort-varSortP  = FVar  <$> parens (fromInteger <$> integerP)+varSortP :: Parser Sort+varSortP  = FVar  <$> parens intP  -- | Parser for function sorts without the "func" keyword.-funcSortP :: ParserV v Sort+funcSortP :: Parser Sort funcSortP = parens $ mkFFunc <$> intP <* comma <*> sortsP -sortsP :: ParserV v [Sort]-sortsP = try (brackets (sepBy sortP semi))-      <|> brackets (sepBy sortP comma)+sortsP :: Parser [Sort]+sortsP = try (brackets (sepBy sortP semi)) +      <|> (brackets (sepBy sortP comma))   -- | Parser for sorts (types).-sortP    :: ParserV v Sort+sortP    :: Parser Sort sortP    = sortP' (many sortArgP) -sortArgP :: ParserV v Sort+sortArgP :: Parser Sort sortArgP = sortP' (return [])  {-@@ -1051,110 +1000,146 @@ -- -- TODO, Andres: document the parameter better. ---sortP' :: ParserV v [Sort] -> ParserV v Sort+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)-  <|> (FNatNum <$> natural) -tvarP :: ParserV v Sort+tvarP :: Parser Sort tvarP    =  (string "@" >> varSortP)   <|> (FObj . symbol <$> lowerIdP)  -fTyConP :: ParserV v FTycon+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 "frac"    >> return fracFTyCon)   <|> (reserved "Str"     >> return strFTyCon)-  <|> (mkFTycon          =<<  locUpperIdP)+  <|> (symbolFTycon      <$> locUpperIdP) -mkFTycon :: LocSymbol -> ParserV v FTycon-mkFTycon locSymbol = do-  nums  <- gets numTyCons-  return (symbolNumInfoFTyCon locSymbol (val locSymbol `S.member` nums) False)+-- | 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 :: ParserV v (ExprV v)+trueP :: Parser Expr trueP  = reserved "true"  >> return PTrue  -- | Parser for the reserved constant "false".-falseP :: ParserV v (ExprV v)+falseP :: Parser Expr falseP = reserved "false" >> return PFalse -kvarPredP :: ParseableV v => ParserV v (ExprV v)-kvarPredP = do-  k   <- kvarP-  tsu <- tySubP-  PKVar k tsu <$> substP+kvarPredP :: Parser Expr+kvarPredP = PKVar <$> kvarP <*> substP -kvarP :: ParserV v KVar+kvarP :: Parser KVar kvarP = KV <$> lexeme (char '$' *> symbolR) -substP :: ParseableV v => ParserV v (KVarSubst Symbol v)-substP = mkSu <$> many (brackets $ pairP symbolP aP exprP)+substP :: Parser Subst+substP = mkSubst <$> many (brackets $ pairP symbolP aP exprP)   where     aP = reservedOp ":=" --- | Parses the type-variable substitution section of a PKVar expression.--- An empty section looks like @[@]@; a non-empty one like @[\@sym:=sort;...]@.--- Returns an empty map if neither form is found (backward compat).-tySubP :: ParserV v (M.HashMap Symbol Sort)-tySubP = try tySub <|> pure M.empty-  where-    tySub = brackets (char '@' >> (M.fromList <$> sepBy1 tyPairP (sym ";")))-    tyPairP = do-      s <- symbolP-      _ <- reservedOp ":="-      t <- sortP-      return (s, t)- -- | Parses a semicolon-separated bracketed list of predicates. -- -- Used as the argument of the prefix-versions of conjunction and -- disjunction. ---predsP :: ParseableV v => ParserV v [ExprV v]-predsP = brackets $ sepBy exprP semi+predsP :: Parser [Expr]+predsP = brackets $ sepBy predP semi  -- | Parses a predicate. ---predP  :: ParseableV v => ParserV v (ExprV v)-predP  = exprP+-- 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)]] -existP :: ParseableV v => ParserV v (ExprV v)-existP = do-    allow <- gets allowExists-    if allow then do-      reserved "exists"-      bs <- brackets $ sepBy ((,) <$> bindP <*> sortP) comma-      _ <- dot-      PExist bs <$> exprP-     else-      empty+-- | 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 :: ParseableV v => ParserV v (ExprV v)-refaP =  try (PAnd <$> brackets (sepBy exprP semi))-     <|> exprP+refaP :: Parser Expr+refaP =  try (pAnd <$> brackets (sepBy predP semi))+     <|> predP   -- | (Sorted) Refinements with configurable sub-parsers@@ -1170,7 +1155,7 @@  -- bindP      = symbol    <$> (lowerIdP <* colon) -- | Binder (lowerIdP <* colon)-bindP :: ParserV v Symbol+bindP :: Parser Symbol bindP = symbolP <* colon  optBindP :: Symbol -> Parser Symbol@@ -1204,40 +1189,42 @@ --------------------------------------------------------------------------------  -- | Qualifiers-qualifierP :: ParseableV v => ParserV v Sort -> ParserV v (QualifierV v)+qualifierP :: Parser Sort -> Parser Qualifier qualifierP tP = do   pos    <- getSourcePos   n      <- upperIdP   params <- parens $ sepBy1 (qualParamP tP) comma-  body   <- braces exprP+  _      <- colon+  body   <- predP   return  $ mkQual n params body pos -qualParamP :: ParserV v Sort -> ParserV v QualParam+qualParamP :: Parser Sort -> Parser QualParam qualParamP tP = do   x     <- symbolP   pat   <- qualPatP   _     <- colon-  QP x pat <$> tP+  t     <- tP+  return $ QP x pat t -qualPatP :: ParserV v QualPattern+qualPatP :: Parser QualPattern qualPatP    =  (reserved "as" >> qualStrPatP)   <|> return PatNone -qualStrPatP :: ParserV v QualPattern+qualStrPatP :: Parser QualPattern qualStrPatP    = (PatExact <$> symbolP)   <|> parens (    (uncurry PatPrefix <$> pairP symbolP dot qpVarP)               <|> (uncurry PatSuffix <$> pairP qpVarP  dot symbolP) )  -qpVarP :: ParserV v Int+qpVarP :: Parser Int qpVarP = char '$' *> intP  symBindP :: Parser a -> Parser (Symbol, a) symBindP = pairP symbolP colon -pairP :: ParserV v a -> ParserV v z -> ParserV v b -> ParserV v (a, b)+pairP :: Parser a -> Parser z -> Parser b -> Parser (a, b) pairP xP sepP yP = (,) <$> xP <* sepP <*> yP  ---------------------------------------------------------------------@@ -1250,10 +1237,8 @@   _          <- spaces   _          <- reserved "="   _          <- spaces-  e <- braces exprP-  (lhs, rhs) <- case e of-                  PAtom Eq l r -> return (l, r)-                  _ -> error "Expected rewrite rule of the form: LHS = RHS"+  (lhs, rhs) <- braces $+      pairP exprP (reserved "=") exprP   return $ AutoRewrite args lhs rhs  @@ -1262,27 +1247,16 @@   name   <- symbolP   params <- parens        $ sepBy (symBindP sortP) comma   sort   <- colon        *> sortP-  body   <- reserved "=" *> braces exprP+  body   <- reserved "=" *> braces (+              if sort == boolSort then predP else exprP+               )   return  $ mkEquation name params body sort -defineLocalP :: Parser (Int, [(Symbol, Expr)])-defineLocalP = do-  bid <- intP-  rews <- brackets $ sepBy rewriteP $ reserved ";"-  pure (bid, rews)--rewriteP :: Parser (Symbol, Expr)-rewriteP = do-        x <- symbolP-        reserved ":="-        e <- exprP-        return (x, e)- matchP :: Parser Rewrite-matchP = SMeasure <$> symbolP <*> symbolP <*> many symbolP <*> braces exprP+matchP = SMeasure <$> symbolP <*> symbolP <*> many symbolP <*> (reserved "=" >> exprP)  pairsP :: Parser a -> Parser b -> Parser [(a, b)]-pairsP aP bP = brackets $ sepBy (pairP aP (reserved ":") bP) semi+pairsP aP bP = brackets $ sepBy1 (pairP aP (reserved ":") bP) semi --------------------------------------------------------------------- -- | Parsing Constraints (.fq files) -------------------------------- ---------------------------------------------------------------------@@ -1297,11 +1271,10 @@   | Qul !Qualifier   | Kut !KVar   | Pack !KVar !Int-  | IBind !Int !Symbol !SortedReft !a-  | EBind !Int !Symbol !Sort !a+  | IBind !Int !Symbol !SortedReft+  | EBind !Int !Symbol !Sort   | Opt !String   | Def !Equation-  | LDef !(Int, [(Symbol, Expr)])   | Mat !Rewrite   | Expand ![(Int,Bool)]   | Adt  !DataDecl@@ -1316,22 +1289,21 @@                return $ FIO (defsFInfo ps) [s | Opt s <- ps]  fInfoP :: Parser (FInfo ())-fInfoP = defsFInfo <$> {- SCC "many-defP" -} many defP+fInfoP = defsFInfo <$> {- SCC "many-defP" #-} many defP  defP :: Parser (Def ()) defP =  Srt   <$> (reserved "sort"         >> colon >> sortP)-    <|> Cst   <$> (reserved "constraint"   >> colon >> {- SCC "subCP" -} subCP)-    <|> Wfc   <$> (reserved "wf"           >> colon >> {- SCC "wfCP"  -} wfCP)+    <|> Cst   <$> (reserved "constraint"   >> colon >> {- SCC "subCP" #-} subCP)+    <|> Wfc   <$> (reserved "wf"           >> colon >> {- SCC "wfCP"  #-} wfCP)     <|> Con   <$> (reserved "constant"     >> symbolP) <*> (colon >> sortP)     <|> Dis   <$> (reserved "distinct"     >> symbolP) <*> (colon >> sortP)     <|> Pack  <$> (reserved "pack"         >> kvarP)   <*> (colon >> intP)     <|> Qul   <$> (reserved "qualif"       >> qualifierP sortP)     <|> Kut   <$> (reserved "cut"          >> kvarP)-    <|> EBind <$> (reserved "ebind"        >> intP) <*> symbolP <*> (colon >> braces sortP) <*> pure ()-    <|> IBind <$> (reserved "bind"         >> intP) <*> symbolP <*> (colon >> sortedReftP)  <*> pure ()+    <|> EBind <$> (reserved "ebind"        >> intP) <*> symbolP <*> (colon >> braces sortP)+    <|> IBind <$> (reserved "bind"         >> intP) <*> symbolP <*> (colon >> sortedReftP)     <|> Opt    <$> (reserved "fixpoint"    >> stringLiteral)     <|> Def    <$> (reserved "define"      >> defineP)-    <|> LDef   <$> (reserved "defineLocal" >> defineLocalP)     <|> Mat    <$> (reserved "match"       >> matchP)     <|> Expand <$> (reserved "expand"      >> pairsP intP boolP)     <|> Adt    <$> (reserved "data"        >> dataDeclP)@@ -1346,11 +1318,9 @@ wfCP = do reserved "env"           env <- envP           reserved "reft"-          r <- sortedReftP-          case wfC env r () of-            [w]   -> return w-            []    -> error "Unexpected empty list in wfCP"-            _:_:_ -> error "Expected a single element list in wfCP"+          r   <- sortedReftP+          let [w] = wfC env r ()+          return w  subCP :: Parser (SubC ()) subCP = do pos <- getSourcePos@@ -1363,7 +1333,8 @@            reserved "id"            i   <- natural <* spaces            tag <- tagP-           subC' env lhs rhs i tag pos <$> getSourcePos+           pos' <- getSourcePos+           return $ subC' env lhs rhs i tag pos pos'  subC' :: IBindEnv       -> SortedReft@@ -1389,26 +1360,23 @@ envP  = do binds <- brackets $ sepBy (intP <* spaces) semi            return $ insertsIBindEnv binds emptyIBindEnv -intP :: ParserV v Int+intP :: Parser Int intP = fromInteger <$> natural -integerP :: ParserV v Integer-integerP =-        (try (char '-') >> negate <$> natural)-    <|> natural- boolP :: Parser Bool boolP = (reserved "True" >> return True)     <|> (reserved "False" >> return False)  defsFInfo :: [Def a] -> FInfo a-defsFInfo defs = {- SCC "defsFI" -} Types.FI cm ws bs lts dts kts qs binfo adts mempty mempty ae lrws mempty+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    [(n,(x,r,a)) | IBind n x r a <- defs]+    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]@@ -1419,17 +1387,16 @@     rews       =                    [r                  | Mat r       <- defs]     autoRWs    = M.fromList         [(arId , s)         | AutoRW arId s <- defs]     rwEntries  =                    [(i, f)             | RWMap fs   <- defs, (i,f) <- fs]-    rwMap      = List.foldl' insert (M.fromList []) rwEntries+    rwMap      = foldl insert (M.fromList []) rwEntries                  where-                   insert map' (cid', arId) =+                   insert map (cid, arId) =                      case M.lookup arId autoRWs of                        Just rewrite ->-                         M.insertWith (++) (fromIntegral cid') [rewrite] map'+                         M.insertWith (++) (fromIntegral cid) [rewrite] map                        Nothing ->-                         map'+                         map     cid        = fromJust . sid     ae         = AEnv eqs rews expand rwMap-    lrws       = LocalRewritesMap $ M.fromList [ (bid, LocalRewrites $ M.fromList rws) | LDef (bid, rws) <- defs ]     adts       =                    [d                  | Adt d       <- defs]     -- msg    = show $ "#Lits = " ++ (show $ length consts) @@ -1447,8 +1414,30 @@ crashP pp = do   i   <- pp   msg <- takeWhileP Nothing (const True) -- consume the rest of the input-  return $ Crash [(i, Nothing)] msg+  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@@ -1462,21 +1451,13 @@        return (res, str, pos)  -- | Initial parser state.-initPState-  :: ParseableV v-  -- The expression to produce when the composition operator is parsed (@f . g@)-  ---  -- Receives the location of the composition operator.-  => Maybe (Located String -> ExprV v)-  -> PStateV v+initPState :: Maybe Expr -> PState initPState cmpFun = PState { fixityTable = bops cmpFun                            , empList     = Nothing                            , singList    = Nothing                            , fixityOps   = []                            , supply      = 0                            , layoutStack = Empty-                           , numTyCons   = S.empty-                           , allowExists = False                            }  -- | Entry point for parsing, for testing.@@ -1485,11 +1466,8 @@ -- Fails with an exception on a parse error. -- doParse' :: Parser a -> SourceName -> String -> a-doParse' = doParse'' False--doParse'' :: Bool -> Parser a -> SourceName -> String -> a-doParse'' allowEx parser fileName input =-  case runParser (evalStateT (spaces *> parser <* eof) ((initPState Nothing) { allowExists = allowEx})) fileName input of+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@@ -1516,7 +1494,7 @@ parseFromStdIn p = doParse' p "stdin" . T.unpack <$> T.getContents  -- | Obtain a fresh integer during the parsing process.-freshIntP :: ParserV v Integer+freshIntP :: Parser Integer freshIntP = do n <- gets supply                modify (\ s -> s{supply = n + 1})                return n@@ -1533,7 +1511,7 @@  <|> (reserved "push"     >> return Push)  <|> (reserved "pop"      >> return Pop)  <|> (reserved "check"    >> return CheckSat)- <|> (reserved "assert"   >> (Assert Nothing <$> exprP))+ <|> (reserved "assert"   >> (Assert Nothing <$> predP))  <|> (reserved "distinct" >> (Distinct <$> brackets (sepBy exprP comma)))  cmdVarP :: Parser Command@@ -1565,14 +1543,115 @@ 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+  rr' = {- SCC "fInfoP" #-} doParse' fInfoP  instance Inputable (FInfoWithOpts ()) where-  rr' = {- SCC "fInfoWithOptsP" -} doParse' fInfoOptP+  rr' = {- SCC "fInfoWithOptsP" #-} doParse' fInfoOptP  instance Inputable Command where   rr' = doParse' commandP  instance Inputable [Command] where   rr' = doParse' commandsP++{-+---------------------------------------------------------------+--------------------------- Testing ---------------------------+---------------------------------------------------------------++-- A few tricky predicates for parsing+-- myTest1 = "((((v >= 56320) && (v <= 57343)) => (((numchars a o ((i - o) + 1)) == (1 + (numchars a o ((i - o) - 1)))) && (((numchars a o (i - (o -1))) >= 0) && (((i - o) - 1) >= 0)))) && ((not (((v >= 56320) && (v <= 57343)))) => (((numchars a o ((i - o) + 1)) == (1 + (numchars a o (i - o)))) && ((numchars a o (i - o)) >= 0))))"+--+-- myTest2 = "len x = len y - 1"+-- myTest3 = "len x y z = len a b c - 1"+-- myTest4 = "len x y z = len a b (c - 1)"+-- myTest5 = "x >= -1"+-- myTest6 = "(bLength v) = if n > 0 then n else 0"+-- myTest7 = "(bLength v) = (if n > 0 then n else 0)"+-- myTest8 = "(bLength v) = (n > 0 ? n : 0)"+++sa  = "0"+sb  = "x"+sc  = "(x0 + y0 + z0) "+sd  = "(x+ y * 1)"+se  = "_|_ "+sf  = "(1 + x + _|_)"+sg  = "f(x,y,z)"+sh  = "(f((x+1), (y * a * b - 1), _|_))"+si  = "(2 + f((x+1), (y * a * b - 1), _|_))"++s0  = "true"+s1  = "false"+s2  = "v > 0"+s3  = "(0 < v && v < 100)"+s4  = "(x < v && v < y+10 && v < z)"+s6  = "[(v > 0)]"+s6' = "x"+s7' = "(x <=> y)"+s8' = "(x <=> a = b)"+s9' = "(x <=> (a <= b && b < c))"++s7  = "{ v: Int | [(v > 0)] }"+s8  = "x:{ v: Int | v > 0 } -> {v : Int | v >= x}"+s9  = "v = x+y"+s10 = "{v: Int | v = x + y}"++s11 = "x:{v:Int | true } -> {v:Int | true }"+s12 = "y : {v:Int | true } -> {v:Int | v = x }"+s13 = "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}"+s14 = "x:{v:a  | true} -> y:{v:b | true } -> {v:a | (x < v && v < y) }"+s15 = "x:Int -> Bool"+s16 = "x:Int -> y:Int -> {v:Int | v = x + y}"+s17 = "a"+s18 = "x:a -> Bool"+s20 = "forall a . x:Int -> Bool"++s21 = "x:{v : GHC.Prim.Int# | true } -> {v : Int | true }"++r0  = (rr s0) :: Pred+r0' = (rr s0) :: [Refa]+r1  = (rr s1) :: [Refa]+++e1, e2  :: Expr+e1  = rr "(k_1 + k_2)"+e2  = rr "k_1"++o1, o2, o3 :: FixResult Integer+o1  = rr "SAT "+o2  = rr "UNSAT [1, 2, 9,10]"+o3  = rr "UNSAT []"++-- sol1 = doParse solution1P "solution: k_5 := [0 <= VV_int]"+-- sol2 = doParse solution1P "solution: k_4 := [(0 <= VV_int)]"++b0, b1, b2, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13 :: BareType+b0  = rr "Int"+b1  = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}"+b2  = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y}"+b4  = rr "forall a . x : a -> Bool"+b5  = rr "Int -> Int -> Int"+b6  = rr "(Int -> Int) -> Int"+b7  = rr "({v: Int | v > 10} -> Int) -> Int"+b8  = rr "(x:Int -> {v: Int | v > x}) -> {v: Int | v > 10}"+b9  = rr "x:Int -> {v: Int | v > x} -> {v: Int | v > 10}"+b10 = rr "[Int]"+b11 = rr "x:[Int] -> {v: Int | v > 10}"+b12 = rr "[Int] -> String"+b13 = rr "x:(Int, [Bool]) -> [(String, String)]"++-- b3 :: BareType+-- b3  = rr "x:Int -> y:Int -> {v:Bool | ((v is True) <=> x = y)}"++m1 = ["len :: [a] -> Int", "len (Nil) = 0", "len (Cons x xs) = 1 + len(xs)"]+m2 = ["tog :: LL a -> Int", "tog (Nil) = 100", "tog (Cons y ys) = 200"]++me1, me2 :: Measure.Measure BareType Symbol+me1 = (rr $ intercalate "\n" m1)+me2 = (rr $ intercalate "\n" m2)+-}
+ src/Language/Fixpoint/Smt/Bitvector.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}++module Language.Fixpoint.Smt.Bitvector+       ( -- * Constructor+         Bv (..)++         -- * Sizes+       , BvSize (..)++         -- * Operators+       , BvOp (..)++         -- * BitVector Sort Constructor+       , mkSort++         -- * BitVector Expression Constructor+       , eOp++         -- * BitVector Type Constructor+       , bvTyCon++       ) where++import           Data.Generics           (Data)+import qualified Data.Text               as T+import           Data.Typeable           (Typeable)+import           GHC.Generics            (Generic)+import           Language.Fixpoint.Types.Names+import           Language.Fixpoint.Types++data Bv     = Bv !BvSize !String++data BvSize = S32   | S64+              deriving (Eq, Ord, Show, Data, Typeable, Generic)++data BvOp   = BvAnd | BvOr+              deriving (Eq, Ord, Show, Data, Typeable, Generic)++-- | Construct the bitvector `Sort` from its `BvSize`+mkSort :: BvSize -> Sort+mkSort s = fApp (fTyconSort bvTyCon) [ fTyconSort (sizeTyCon s) ]++bvTyCon :: FTycon+bvTyCon = symbolFTycon $ dummyLoc bitVecName++sizeTyCon    :: BvSize -> FTycon+sizeTyCon    = symbolFTycon . dummyLoc . sizeName++sizeName :: BvSize -> Symbol+sizeName S32 = size32Name+sizeName S64 = size64Name++-- | Construct an `Expr` using a raw string, e.g. (Bv S32 "#x02000000")+instance Expression Bv where+  expr (Bv sz v) = ECon $ L (T.pack v) (mkSort sz)++-- | Apply some bitvector operator to a list of arguments+eOp :: BvOp -> [Expr] -> Expr+eOp b es = foldl EApp (EVar $ opName b) es++opName :: BvOp -> Symbol+opName BvAnd = bvAndName+opName BvOr  = bvOrName+++-- sizeSort     = (`FApp` [fObj $ dummyLoc $ symbol "obj"]) . sizeTC+-- s32TyCon     = symbolFTycon $ dummyLoc size32Name+-- s64TyCon     = symbolFTycon $ dummyLoc size64Name
src/Language/Fixpoint/Smt/Interface.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                       #-} {-# LANGUAGE BangPatterns              #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -6,9 +7,6 @@ {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE DoAndIfThenElse           #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Use isNothing" #-}  -- | This module contains an SMTLIB2 interface for --   1. checking the validity, and,@@ -18,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@@ -38,6 +53,7 @@      -- * Execute Queries     , command+    , smtExit     , smtSetMbqi      -- * Query API@@ -45,14 +61,19 @@     , smtDecls     , smtDefineFunc     , smtAssert-    , smtAssertDecl     , smtFuncDecl     , smtAssertAxiom     , smtCheckUnsat+    , smtCheckSat     , smtBracket, smtBracketAt     , smtDistinct     , smtPush, smtPop-    , smtComment+    , smtAssertAsync+    , smtCheckUnsatAsync+    , readCheckUnsat+    , smtBracketAsyncAt+    , smtPushAsync+    , smtPopAsync      -- * Check Validity     , checkValid@@ -60,12 +81,17 @@     , checkValidWithContext     , checkValids -    , funcSortVars-     ) where -import           Language.Fixpoint.Types.Config ( SMTSolver (..), solverFlags-                                                , Config (solver, smtTimeout, noStringTheory, save, saveDir, allowHO))+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+                                                , smtTimeout+                                                , gradual+                                                , stringTheory) import qualified Language.Fixpoint.Misc          as Misc import           Language.Fixpoint.Types.Errors import           Language.Fixpoint.Utils.Files@@ -76,25 +102,25 @@ import           Language.Fixpoint.Smt.Serialize () import           Control.Applicative      ((<|>)) import           Control.Monad-import           Control.Monad.State import           Control.Exception-import           Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as Char8 import           Data.Char import qualified Data.HashMap.Strict      as M-import           Data.List                (uncons) import           Data.Maybe              (fromMaybe)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup          (Semigroup (..))+#endif+ import qualified Data.Text                as T-import qualified Data.Text.Encoding       as TE-import qualified Data.Text.IO -- import           Data.Text.Format+import qualified Data.Text.IO             as TIO+import qualified Data.Text.Lazy           as LT import qualified Data.Text.Lazy.IO        as LTIO import           System.Directory-import           Language.Fixpoint.Verbosity+import           System.Console.CmdArgs.Verbosity+import           System.Exit              hiding (die) import           System.FilePath 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)@@ -103,11 +129,6 @@ import           Language.Fixpoint.Utils.Builder as Builder -- import qualified Language.Fixpoint.Types as F -- import           Language.Fixpoint.Types.PrettyPrint (tracepp)-import qualified SMTLIB.Backends-import qualified SMTLIB.Backends.Process as Process-import qualified Language.Fixpoint.Conditional.Z3 as Conditional.Z3-import Control.Concurrent.Async (async)-import GHC.Stack (HasCallStack)  {- runFile f@@ -123,42 +144,35 @@        return zs -} -checkValidWithContext-  :: HasCallStack => [(Symbol, Sort)] -> Expr -> Expr -> SmtM Bool-checkValidWithContext xts p q =-  smtBracket "checkValidWithContext" $-    checkValid' xts p q+checkValidWithContext :: Context -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool+checkValidWithContext me xts p q =+  smtBracket me "checkValidWithContext" $+    checkValid' me xts p q  -- | type ClosedPred E = {v:Pred | subset (vars v) (keys E) } -- checkValid :: e:Env -> ClosedPred e -> ClosedPred e -> IO Bool-checkValid-  :: HasCallStack-  => Config -> FilePath -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool+checkValid :: Config -> FilePath -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool checkValid cfg f xts p q = do   me <- makeContext cfg f-  evalStateT (checkValid' xts p q) me+  checkValid' me xts p q -checkValid' :: HasCallStack => [(Symbol, Sort)] -> Expr -> Expr -> SmtM Bool-checkValid' xts p q = do-  smtDecls xts-  smtAssertDecl $ pAnd [p, PNot q]-  smtCheckUnsat+checkValid' :: Context -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool+checkValid' me xts p q = do+  smtDecls me xts+  smtAssert me $ pAnd [p, PNot q]+  smtCheckUnsat me  -- | If you already HAVE a context, where all the variables have declared types --   (e.g. if you want to make MANY repeated Queries)  -- checkValid :: e:Env -> [ClosedPred e] -> IO [Bool] checkValids :: Config -> FilePath -> [(Symbol, Sort)] -> [Expr] -> IO [Bool]-checkValids cfg f xts ps = do-  me <- makeContext cfg f-  evalStateT (checkValids' xts ps) me--checkValids' :: [(Symbol, Sort)] -> [Expr] -> SmtM [Bool]-checkValids' xts ps = do-  smtDecls xts-  forM ps $ \p ->-     smtBracket "checkValids" $-       smtAssert (PNot p) >> smtCheckUnsat+checkValids cfg f xts ps+  = do me <- makeContext cfg f+       smtDecls me xts+       forM ps $ \p ->+          smtBracket me "checkValids" $+            smtAssert me (PNot p) >> smtCheckUnsat me  -- debugFile :: FilePath -- debugFile = "DEBUG.smt2"@@ -167,65 +181,51 @@ -- | SMT IO -------------------------------------------------------------------- -------------------------------------------------------------------------------- -commandRaw :: Maybe Handle -> SMTLIB.Backends.Solver -> Bool -> Builder -> IO Response-commandRaw ctxLog ctxSolver ctxVerbose cmdBS = do-  resp <- SMTLIB.Backends.command ctxSolver cmdBS-  let respTxt =-        TE.decodeUtf8With (const $ const $ Just ' ') $-        LBS.toStrict resp-  case A.parseOnly responseP respTxt of-    Left e  -> Misc.errorstar $ "SMTREAD:" ++ e-    Right r -> do-      let textResponse = "; SMT Says: " <> T.pack (show r)-      forM_ ctxLog $ \h ->-        Data.Text.IO.hPutStrLn h textResponse-      when ctxVerbose $-        Data.Text.IO.putStrLn textResponse-      return r- -------------------------------------------------------------------------------- {-# SCC command #-}-command  :: HasCallStack => Command -> SmtM Response+command              :: Context -> Command -> IO Response ---------------------------------------------------------------------------------command !cmd       = do-  -- whenLoud $ do LTIO.appendFile debugFile (s <> "\n")-  --               LTIO.putStrLn ("CMD-RAW:" <> s <> ":CMD-RAW:DONE")-  ctxLog <- gets ctxLog-  ctxSolver <- gets ctxSolver-  ctxVerbose <- gets ctxVerbose-  cmdBS <- liftSym $ runSmt2 cmd-  forM_ ctxLog $ \h -> lift $ do-    BS.hPutBuilder h cmdBS-    LBS.hPutStr h "\n"-  lift $ case cmd of-    CheckSat   -> commandRaw ctxLog ctxSolver ctxVerbose cmdBS-    GetValue _ -> commandRaw ctxLog ctxSolver ctxVerbose cmdBS-    _          -> SMTLIB.Backends.command_ ctxSolver cmdBS >> return Ok+command me !cmd       = say >> hear cmd+  where+    env               = ctxSymEnv me+    say               = smtWrite me ({-# SCC "Command-runSmt2" #-} Builder.toLazyText (runSmt2 env cmd))+    hear CheckSat     = smtRead me+    hear (GetValue _) = smtRead me+    hear _            = return Ok --- | A variant of `command` that accepts a pre-built command-commandB :: Builder -> SmtM Response----------------------------------------------------------------------------------commandB cmdBS       = do-  ctxLog <- gets ctxLog-  ctxSolver <- gets ctxSolver-  forM_ ctxLog $ \h -> lift $ do-    BS.hPutBuilder h cmdBS-    LBS.hPutStr h "\n"-  lift $ SMTLIB.Backends.command_ ctxSolver cmdBS >> return Ok+smtExit :: Context -> IO ()+smtExit me = asyncCommand me Exit -smtSetMbqi :: SmtM ()-smtSetMbqi = interact' SetMbqi+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+  when (ctxVerbose me) $ LTIO.putStrLn "SMT READ"+  ln  <- smtReadRaw me+  res <- A.parseWith (smtReadRaw me) responseP ln+  case A.eitherResult res of+    Left e  -> Misc.errorstar $ "SMTREAD:" ++ e+    Right r -> do+      maybe (return ()) (\h -> LTIO.hPutStrLn h $ blt ("; SMT Says: " <> (bShow r))) (ctxLog me)+      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@@ -235,20 +235,20 @@ valuesP = A.many1' pairP <* A.char ')'  pairP :: SmtParser (Symbol, T.Text)-pairP = {- SCC "pairP" -}+pairP = {- SCC "pairP" #-}   do A.skipSpace-     _ <- A.char '('+     A.char '('      !x <- symbolP      A.skipSpace      !v <- valueP-     _ <- A.char ')'+     A.char ')'      return (x,v)  symbolP :: SmtParser Symbol-symbolP = {- SCC "symbolP" -} symbol <$> A.takeWhile1 (not . isSpace)+symbolP = {- SCC "symbolP" #-} symbol <$> A.takeWhile1 (not . isSpace)  valueP :: SmtParser T.Text-valueP = {- SCC "valueP" -} negativeP+valueP = {- SCC "valueP" #-} negativeP       <|> A.takeWhile1 (\c -> not (c == ')' || isSpace c))  negativeP :: SmtParser T.Text@@ -256,288 +256,308 @@   = do v <- A.char '(' *> A.takeWhile1 (/=')') <* A.char ')'        return $ "(" <> v <> ")" +smtWriteRaw      :: Context -> Raw -> IO ()+smtWriteRaw me !s = {- SCC "smtWriteRaw" #-} do+  -- whenLoud $ do LTIO.appendFile debugFile (s <> "\n")+  --               LTIO.putStrLn ("CMD-RAW:" <> s <> ":CMD-RAW:DONE")+  hPutStrLnNow (ctxCout me) s+  maybe (return ()) (`LTIO.hPutStrLn` s) (ctxLog me)++smtReadRaw       :: Context -> IO T.Text+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 --------------------------------------------------------- --------------------------------------------------------------------------  ---------------------------------------------------------------------------makeContext :: Config -> FilePath -> IO Context+makeContext   :: Config -> FilePath -> IO Context -------------------------------------------------------------------------- makeContext cfg f-  = do mb_hLog <- if not (save cfg) then pure Nothing else do-           createDirectoryIfMissing True $ takeDirectory smtFile-           hLog <- openFile smtFile WriteMode-           hSetBuffering hLog $ BlockBuffering $ Just $ 1024 * 1024 * 64-           return $ Just hLog-       me   <- makeContext' cfg mb_hLog+  = do me   <- makeProcess cfg        pre  <- smtPreamble cfg (solver cfg) me-       forM_ pre $ \line -> do-           SMTLIB.Backends.command_ (ctxSolver me) line-           forM_ mb_hLog $ \hLog -> do-               BS.hPutBuilder hLog line-               LBS.hPutStr hLog "\n"-       return 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'     where-       smtFile = extFileNameR' (saveDir cfg) Smt2 f+       smtFile = extFileName Smt2 f -makeContextWithSEnv :: Config -> FilePath -> SymEnv -> DefinedFuns -> IO Context-makeContextWithSEnv cfg f env defns = do-  ctx      <- makeContext cfg f-  let ctx' = ctx {ctxSymEnv = env, ctxDefines = defns}-  execStateT declare ctx'+makeContextWithSEnv :: Config -> FilePath -> SymEnv -> IO Context+makeContextWithSEnv cfg f env = do+  ctx     <- makeContext cfg f+  let ctx' = ctx {ctxSymEnv = env}+  declare ctx'+  return ctx'+  -- where msg = "makeContextWithSEnv" ++ show env  makeContextNoLog :: Config -> IO Context-makeContextNoLog cfg = do-  me  <- makeContext' cfg Nothing-  pre <- smtPreamble cfg (solver cfg) me-  mapM_ (SMTLIB.Backends.command_ (ctxSolver me)) pre-  return me--makeProcess-  :: Maybe Handle-  -> Process.Config-  -> IO (SMTLIB.Backends.Backend, IO ())-makeProcess ctxLog cfg-  = do handl@Process.Handle {hMaybeErr = Just hErr, ..} <- Process.new cfg-       case ctxLog of-         Nothing -> return ()-         Just hLog -> void $ async $ forever-           (do errTxt <- LTIO.hGetLine hErr-               LTIO.hPutStrLn hLog $ "OOPS, SMT solver error:" <> errTxt-           ) `catch` \ SomeException {} -> return ()-       let backend = Process.toBackend handl-       hSetBuffering hOut $ BlockBuffering $ Just $ 1024 * 1024 * 64-       hSetBuffering hIn $ BlockBuffering $ Just $ 1024 * 1024 * 64-       return (backend, Process.close handl)+makeContextNoLog cfg+  = do me  <- makeProcess cfg+       pre <- smtPreamble cfg (solver cfg) me+       mapM_ (smtWrite me) pre+       return me -makeContext' :: Config -> Maybe Handle -> IO Context-makeContext' cfg ctxLog-  = do let slv = solver cfg-       (backend, closeIO) <- case slv of-         Z3      ->-           {- "z3 -smt2 -in"                   -}-           {- "z3 -smtc SOFT_TIMEOUT=1000 -in" -}-           {- "z3 -smtc -in MBQI=false"        -}-           makeProcess ctxLog $ Process.defaultConfig-                             { Process.exe = "z3"-                             , Process.args = ["-smt2", "-in"] }-         Z3mem   -> Conditional.Z3.makeZ3-         Mathsat -> makeProcess ctxLog $ Process.defaultConfig-                             { Process.exe = "mathsat"-                             , Process.args = ["-input=smt2"] }-         Cvc4    -> makeProcess ctxLog $-                      Process.defaultConfig-                             { Process.exe = "cvc4"-                             , Process.args = ["-L", "smtlib2"] }-         Cvc5    -> makeProcess ctxLog $-                      Process.defaultConfig-                             { Process.exe = "cvc5"-                             , Process.args = ["-L", "smtlib2", "--arrays-exp"] }-       solver <- SMTLIB.Backends.initSolver SMTLIB.Backends.Queuing backend+makeProcess :: Config -> IO Context+makeProcess cfg+  = do (hOut, hIn, _ ,pid) <- runInteractiveCommand $ smtCmd (solver cfg)        loud <- isLoud-       return Ctx { ctxSolver    = solver-                  , ctxElabF     = solverFlags cfg-                  , ctxClose     = closeIO-                  , ctxLog       = ctxLog-                  , ctxVerbose   = loud-                  , ctxSymEnv    = mempty-                  , ctxIxs       = []-                  , ctxDefines   = mempty-                  -- This is a heurstic to avoid generating large sequences of unused `lam_arg` symbols-                  -- when there's no higher-order reasoning. It might require some tuning on larger codebases-                  -- if `unknown function/constant lam_arg$XXX` errors are encountered.-                  , ctxLams      = allowHO cfg-                  , config       = cfg+       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                   } --- | Close file handles and release the solver backend's resources.-cleanupContext :: Context -> IO ()-cleanupContext Ctx {..} = do+--------------------------------------------------------------------------+cleanupContext :: Context -> IO ExitCode+--------------------------------------------------------------------------+cleanupContext (Ctx {..}) = do+  cancel ctxAsync+  hCloseMe "ctxCin"  ctxCin+  hCloseMe "ctxCout" ctxCout   maybe (return ()) (hCloseMe "ctxLog") ctxLog-  ctxClose+  waitForProcess ctxPid  hCloseMe :: String -> Handle -> IO () hCloseMe msg h = hClose h `catch` (\(exn :: IOException) -> putStrLn $ "OOPS, hClose breaks: " ++ msg ++ show exn) -smtPreamble :: Config -> SMTSolver -> Context -> IO [Builder]-smtPreamble cfg s me-  | s == Z3 || s == Z3mem-    = do v <- getZ3Version me-         checkValidStringFlag Z3 v cfg-         return $ makeMbqi ++ makeTimeout cfg ++ Thy.preamble cfg Z3-  | otherwise-    = checkValidStringFlag s [] cfg >> return (Thy.preamble cfg s)-  where-    makeMbqi = ["\n(set-option :smt.mbqi false)"]+{- "z3 -smt2 -in"                   -}+{- "z3 -smtc SOFT_TIMEOUT=1000 -in" -}+{- "z3 -smtc -in MBQI=false"        -} -getZ3Version :: Context -> IO [Int]-getZ3Version me-  = do -- resp is like (:version "4.8.15")-       resp <- SMTLIB.Backends.command (ctxSolver me) "(get-info :version)"-       case Char8.split '"' resp of-         _:rText:_ -> do-           -- strip off potential " - build hashcode ..." suffix-           let vText = Char8.takeWhile (not . isSpace) rText-           let parsedComponents = [ reads (Char8.unpack cText) | cText <- Char8.split '.' vText ]-           sequence-             [ case pComponent of-                 [(c, "")] -> return c-                 xs -> error $ "Can't parse z3 version: " ++ show xs-             | pComponent <- parsedComponents-             ]-         xs -> error $ "Can't parse z3 (get-info :version): " ++ show xs+smtCmd         :: SMTSolver -> String --  T.Text+smtCmd Z3      = "z3 -smt2 -in"+smtCmd Mathsat = "mathsat -input=smt2"+smtCmd Cvc4    = "cvc4 --incremental -L smtlib2" -checkValidStringFlag :: SMTSolver -> [Int] -> Config -> IO ()+-- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2...+smtPreamble :: Config -> SMTSolver -> Context -> IO [LT.Text]+smtPreamble cfg Z3 me+  = do smtWrite me "(get-info :version)"+       v:_ <- T.words . (!!1) . T.splitOn "\"" <$> smtReadRaw me+       checkValidStringFlag Z3 v cfg+       if T.splitOn "." v `versionGreaterEq` ["4", "3", "2"]+         then return $ z3_432_options ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3+         else return $ z3_options     ++ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3+smtPreamble cfg s _+  = checkValidStringFlag s "" cfg >> return (Thy.preamble cfg s)++checkValidStringFlag :: SMTSolver -> T.Text -> Config -> IO () checkValidStringFlag smt v cfg   = when (noString smt v cfg) $       die $ err dummySpan (text "stringTheory is only supported by z3 version >=4.2.2") -noString :: SMTSolver -> [Int] -> Config -> Bool+noString :: SMTSolver -> T.Text -> Config -> Bool noString smt v cfg-  =  not (noStringTheory cfg)-  && not (smt == Cvc5 || (smt == Z3 && (v >= [4, 4, 2])))+  =  stringTheory cfg+  && not (smt == Z3 && (T.splitOn "." v `versionGreaterEq` ["4", "4", "2"]))+++versionGreaterEq :: Ord a => [a] -> [a] -> Bool+versionGreaterEq (x:xs) (y:ys)+  | x >  y = True+  | x == y = versionGreaterEq xs ys+  | x <  y = False+versionGreaterEq _  [] = True+versionGreaterEq [] _  = False+versionGreaterEq _ _ = Misc.errorstar "Interface.versionGreater called with bad arguments"+ ----------------------------------------------------------------------------- -- | SMT Commands ----------------------------------------------------------- ----------------------------------------------------------------------------- -smtPush, smtPop :: SmtM ()-smtPush = interact' Push-smtPop  = interact' Pop--smtComment :: T.Text -> SmtM ()-smtComment t = interact' (Comment t)+smtPush, smtPop   :: Context -> IO ()+smtPush me        = interact' me Push+smtPop me         = interact' me Pop -smtDecls :: [(Symbol, Sort)] -> SmtM ()-smtDecls = mapM_ $ uncurry smtDecl+smtDecls :: Context -> [(Symbol, Sort)] -> IO ()+smtDecls = mapM_ . uncurry . smtDecl -smtDecl :: Symbol -> Sort -> SmtM ()-smtDecl x t = do-  me <- get-  let env = seData (ctxSymEnv me)-  let ins' = sortSmtSort False env <$> ins-  let out' = sortSmtSort False env     out-  interact' (notracepp _msg $ Declare (symbolSafeText x) ins' out')+smtDecl :: Context -> Symbol -> Sort -> IO ()+smtDecl me x t = interact' me ({- notracepp msg $ -} Declare (symbolSafeText x) ins' out')   where+    ins'       = sortSmtSort False env <$> ins+    out'       = sortSmtSort False env     out     (ins, out) = deconSort t-    _msg       = "smtDecl: " ++ showpp (x, t, ins, out)+    _msg        = "smtDecl: " ++ showpp (x, t, ins, out)+    env        = seData (ctxSymEnv me) -smtFuncDecl :: T.Text -> ([SmtSort],  SmtSort) -> SmtM ()-smtFuncDecl x (ts, t) = interact' (Declare x ts t)+smtFuncDecl :: Context -> T.Text -> ([SmtSort],  SmtSort) -> IO ()+smtFuncDecl me x (ts, t) = interact' me (Declare x ts t) -smtDataDecl :: [DataDecl] -> SmtM ()-smtDataDecl ds = interact' (DeclData ds)+smtDataDecl :: Context -> [DataDecl] -> IO ()+smtDataDecl me ds = interact' me (DeclData ds)  deconSort :: Sort -> ([Sort], Sort) deconSort t = case functionSort t of                 Just (_, ins, out) -> (ins, out)-                Nothing            -> ([], t)--smtAssert :: Expr -> SmtM ()-smtAssert p = interact' (Assert Nothing p)+                Nothing            -> ([] , t  ) --- the following three functions will emit additional `apply`,--- `coerce`, and `lambda` symbols for fresh function sorts as needed-smtAssertDecl :: HasCallStack => Expr -> SmtM ()-smtAssertDecl p = interactDecl' (Assert Nothing p)+-- hack now this is used only for checking gradual condition.+smtCheckSat :: Context -> Expr -> IO Bool+smtCheckSat me p+ = smtAssert me p >> (ans <$> command me CheckSat)+ where+   ans Sat = True+   ans _   = False -smtDefineEqn :: Equation -> SmtM ()-smtDefineEqn Equ {..} = smtDefineFunc eqName eqArgs eqSort eqBody+smtAssert :: Context -> Expr -> IO ()+smtAssert me p  = interact' me (Assert Nothing p) -smtDefineFunc :: Symbol -> [(Symbol, F.Sort)] -> F.Sort -> Expr -> SmtM ()-smtDefineFunc name symList rsort e =-  do env <- gets (seData . ctxSymEnv)-     interactDecl' $+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 <$>) symList)+          (map (sortSmtSort False env <$>) params)           (sortSmtSort False env rsort)           e  -----------------------------------------------------------------+-- Async calls to the smt+--+-- See Note [Async SMT API]+----------------------------------------------------------------- -smtAssertAxiom :: Triggered Expr -> SmtM ()-smtAssertAxiom p  = interact' (AssertAx p)+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")) -smtDistinct :: [Expr] -> SmtM ()-smtDistinct az = interact' (Distinct az)+smtAssertAsync :: Context -> Expr -> IO ()+smtAssertAsync me p  = asyncCommand me $ Assert Nothing p -smtCheckUnsat :: HasCallStack => SmtM Bool-smtCheckUnsat = respSat <$> command CheckSat+smtCheckUnsatAsync :: Context -> IO ()+smtCheckUnsatAsync me = asyncCommand me CheckSat -smtBracketAt :: SrcSpan -> String -> SmtM a -> SmtM a-smtBracketAt sp _msg a =-  smtBracket _msg a `catchSMT` dieAt sp+smtBracketAsyncAt :: SrcSpan -> Context -> String -> IO a -> IO a+smtBracketAsyncAt sp x y z = smtBracketAsync x y z `catch` dieAt sp --- | `smtBracket` adds a new level to the apply stack and saves the last fresh index---   on the index stack before the action, and reverts these changes after the action.-smtBracket :: String -> SmtM a -> SmtM a-smtBracket msg a = do-  smtComment (T.pack $ "smtBracket - start: " ++ msg)-  smtPush-  modify $ \ctx ->-    let env = ctxSymEnv ctx in-    ctx { ctxSymEnv = env { seAppls = pushAppls (seAppls env) }-        , ctxIxs = seIx env : ctxIxs ctx}+smtBracketAsync :: Context -> String -> IO a -> IO a+smtBracketAsync me _msg a   = do+  smtPushAsync me   r <- a-  smtPop-  smtComment (T.pack $ "smtBracket - end: " ++ msg)-  modify $ \ctx ->-    let env = ctxSymEnv ctx-        (i , is) = fromMaybe (0, []) (uncons $ ctxIxs ctx)-      in-    ctx { ctxSymEnv = env {seAppls = popAppls (seAppls env) , seIx = i}-        , ctxIxs = is}+  smtPopAsync me   return r -respSat :: HasCallStack => Response -> Bool+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)++smtDistinct :: Context -> [Expr] -> IO ()+smtDistinct me az = interact' me (Distinct az)++smtCheckUnsat :: Context -> IO Bool+smtCheckUnsat me  = respSat <$> command me CheckSat++smtBracketAt :: SrcSpan -> Context -> String -> IO a -> IO a+smtBracketAt sp x y z = smtBracket x y z `catch` dieAt sp++smtBracket :: Context -> String -> IO a -> IO a+smtBracket me _msg a   = do+  smtPush me+  r <- a+  smtPop me+  return r++respSat :: Response -> Bool respSat Unsat   = True respSat Sat     = False respSat Unknown = False respSat r       = die $ err dummySpan $ text ("crash: SMTLIB2 respSat = " ++ show r) -interact' :: Command -> SmtM ()-interact' cmd  = void $ command cmd+interact' :: Context -> Command -> IO ()+interact' me cmd  = void $ command me cmd --- | a variant of `interact'` which also emits fresh---   `apply`, `coerce`, and `lambda` symbols-interactDecl' :: HasCallStack => Command -> SmtM ()-interactDecl' cmd  = do-  cmdBS <- liftSym $ runSmt2 cmd-  ctx <- get-  let env = ctxSymEnv ctx-  let ats = funcSortVars (ctxLams ctx) env-  forM_ ats $ uncurry smtFuncDecl-  put (ctx {ctxSymEnv = env {seAppls = mergeTopAppls (seApplsCur env) (seAppls env), seApplsCur = M.empty} })-  void $ commandB cmdBS -makeTimeout :: Config -> [Builder]+makeTimeout :: Config -> [LT.Text] makeTimeout cfg-  | Just i <- smtTimeout cfg = [ "\n(set-option :timeout " <> fromString (show i) <> ")\n"]+  | Just i <- smtTimeout cfg = [ LT.pack ("\n(set-option :timeout " ++ (show i) ++ ")\n")]   | otherwise                = [""]  +makeMbqi :: Config -> [LT.Text]+makeMbqi cfg+  | gradual cfg = [""]+  | otherwise   = ["\n(set-option :smt.mbqi false)"]++-- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2...+z3_432_options :: [LT.Text]+z3_432_options+  = [ "(set-option :auto-config false)"+    , "(set-option :model true)"+    , "(set-option :model.partial false)"]++z3_options :: [LT.Text]+z3_options+  = [ "(set-option :auto-config false)"+    , "(set-option :model true)"+    , "(set-option :model-partial false)"]+++ ---------------------------------------------------------------------------------declare :: SmtM ()+declare :: Context -> IO () -- SolveM () ---------------------------------------------------------------------------------declare = do-  me <- get-  let env        = ctxSymEnv me-  let xts        = symbolSorts (F.seSort env)-  let tx         = elaborate (ElabParam (ctxElabF me) "declare" env)-  let lts        = F.toListSEnv . F.seLits $ env-  let dss        = dataDeclarations          env-  let thyXTs     =             [ (x, t) | (x, t) <- xts, symKind env x == Just F.Uninterp ]-  let qryXTs     = fmap tx <$> [ (x, t) | (x, t) <- xts, symKind env x == Nothing ]-  -- let isKind n   = (n ==)  . symKind env . fst-  let MkDefinedFuns defs = ctxDefines me-  let ess        = distinctLiterals  lts-  let axs        = Thy.axiomLiterals (config me) lts-  forM_ dss              smtDataDecl-  forM_ thyXTs $ uncurry smtDecl-  forM_ qryXTs $ uncurry smtDecl-  forM_ defs             smtDefineEqn-  forM_ ess              smtDistinct-  forM_ axs              smtAssert+declare me = do+  forM_ dss    $           smtDataDecl me+  forM_ thyXTs $ uncurry $ smtDecl     me+  forM_ qryXTs $ uncurry $ smtDecl     me+  forM_ ats    $ uncurry $ smtFuncDecl me+  forM_ ess    $           smtDistinct me+  forM_ axs    $           smtAssert   me+  where+    env        = ctxSymEnv me+    dss        = dataDeclarations          env+    lts        = F.toListSEnv . F.seLits $ env+    ess        = distinctLiterals  lts+    axs        = Thy.axiomLiterals lts+    thyXTs     =                    filter (isKind 1) xts+    qryXTs     = Misc.mapSnd tx <$> filter (isKind 2) xts+    isKind n   = (n ==)  . symKind env . fst+    xts        = {- tracepp "symbolSorts" $ -} symbolSorts (F.seSort env) +    tx         = elaborate    "declare" env+    ats        = funcSortVars env  symbolSorts :: F.SEnv F.Sort -> [(F.Symbol, F.Sort)] symbolSorts env = [(x, tx t) | (x, t) <- F.toListSEnv env ]@@ -548,31 +568,37 @@ dataDeclarations :: SymEnv -> [[DataDecl]] dataDeclarations = orderDeclarations . map snd . F.toListSEnv . F.seData --- | See 'F.seApplsCur' for explanation.-funcSortVars :: Bool -> F.SymEnv -> [(T.Text, ([F.SmtSort], F.SmtSort))]-funcSortVars lams env =-    concatMap symbolsForTag $ M.toList $ F.seApplsCur env+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]+                 ++ [(var (lamArgSymbol i) t , argSort t) | t@(_,F.SInt) <- ts, i <- [1..Thy.maxLamArg] ]   where-    symbolsForTag (t, i) =-      let applySym  = symbolAtSortIndex applyName i-          coerceSym = symbolAtSortIndex coerceName i-          lamSym    = symbolAtSortIndex lambdaName i-          argSyms   = if lams && snd t == F.SInt-                        then [ (symbolAtSortIndex (lamArgSymbol j) i, argSort t)-                             | j <- [1..Thy.maxLamArg] ]-                        else []-      in  (applySym, appSort t)-        : (coerceSym, ([fst t], snd t))-        : (lamSym, lamSort t)-        : argSyms-+    var n         = F.symbolAtSmtName n env ()+    ts            = M.keys (F.seAppls env)     appSort (s,t) = ([F.SInt, s], t)     lamSort (s,t) = ([s, t], F.SInt)     argSort (s,_) = ([]    , s) -symKind :: F.SymEnv -> F.Symbol -> Maybe Sem-symKind env x = F.tsInterp <$> F.symEnvTheory x env+-- | 'symKind' returns {0, 1, 2} where:+--   0 = Theory-Definition,+--   1 = Theory-Declaration,+--   2 = Query-Binder +symKind :: F.SymEnv -> F.Symbol -> Int+symKind env x = case F.tsInterp <$> F.symEnvTheory x env of+                  Just F.Theory   -> 0+                  Just F.Ctor     -> 0+                  Just F.Test     -> 0+                  Just F.Field    -> 0+                  Just F.Uninterp -> 1+                  Nothing         -> 2+              -- Just t  -> if tsInterp t then 0 else 1+++-- assumes :: [F.Expr] -> SolveM ()+-- assumes es = withContext $ \me -> forM_  es $ smtAssert me+ -- | `distinctLiterals` is used solely to determine the set of literals --   (of each sort) that are *disequal* to each other, e.g. EQ, LT, GT, --   or string literals "cat", "dog", "mouse". These should only include@@ -583,3 +609,4 @@     tess             = Misc.groupList [(t, F.expr x) | (x, t) <- xts, notFun t]     notFun           = not . F.isFunctionSortedReft . (`F.RR` F.trueReft)     -- _notStr          = not . (F.strSort ==) . F.sr_sort . (`F.RR` F.trueReft)+
src/Language/Fixpoint/Smt/Serialize.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE CPP                  #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE DoAndIfThenElse      #-} -{-# OPTIONS_GHC -Wno-orphans        #-}- -- | This module contains the code for serializing Haskell values --   into SMTLIB2 format, that is, the instances for the @SMTLIB2@ --   typeclass. We split it into a separate module as it depends on@@ -14,81 +13,63 @@  module Language.Fixpoint.Smt.Serialize (smt2SortMono) where -import           Control.Monad.State-import           Data.ByteString.Builder (Builder) import           Language.Fixpoint.SortCheck import           Language.Fixpoint.Types import qualified Language.Fixpoint.Types.Visitor as Vis import           Language.Fixpoint.Smt.Types import qualified Language.Fixpoint.Smt.Theories as Thy+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup                 (Semigroup (..))+#endif  -- import           Data.Text.Format import           Language.Fixpoint.Misc (sortNub, errorstar) import           Language.Fixpoint.Utils.Builder as Builder-import qualified Data.Text as T-import Data.Text (Text) -- import Debug.Trace (trace)  instance SMTLIB2 (Symbol, Sort) where-  smt2 c@(sym, t) =-    -- build "({} {})" (smt2 env sym, smt2SortMono c env t)-    do s <- smt2 sym-       ss <- smt2SortMono c t-       pure $ parenSeqs [s , ss]--instance SMTLIB2 (Symbol, Expr) where-  smt2 (sym, e) =-    do s <- smt2 sym-       ss <- smt2 e-       pure $ parenSeqs [s, ss]+  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 -> Sort -> SymM Builder+smt2SortMono, smt2SortPoly :: (PPrint a) => a -> SymEnv -> Sort -> Builder.Builder smt2SortMono = smt2Sort False smt2SortPoly = smt2Sort True -smt2Sort :: (PPrint a) => Bool -> a -> Sort -> SymM Builder-smt2Sort poly _ t =-  do env <- get-     smt2 (Thy.sortSmtSort poly (seData env) t)--smt2data :: [DataDecl] -> SymM Builder-smt2data = smt2data' . map padDataDecl+smt2Sort :: (PPrint a) => Bool -> a -> SymEnv -> Sort -> Builder.Builder+smt2Sort poly _ env t = smt2 env (Thy.sortSmtSort poly (seData env) t) -smt2data' :: [DataDecl] -> SymM Builder-smt2data' ds =-  do n <- traverse smt2dataname ds-     d <- traverse smt2datactors ds-     pure $ seqs [ parens $ smt2many n , parens $ smt2many d ]+smt2data :: SymEnv -> [DataDecl] -> Builder.Builder+smt2data env = smt2data' env . map padDataDecl +smt2data' :: SymEnv -> [DataDecl] -> Builder.Builder+smt2data' env ds = seqs [ parens $ smt2many (smt2dataname env <$> ds)+                         , parens $ smt2many (smt2datactors env <$> ds)+                         ] -smt2dataname :: DataDecl -> SymM Builder-smt2dataname (DDecl tc as _) =-  do name <- smt2 (symbol tc)-     n    <- smt2 as-     pure $ parenSeqs [name, n]+ +smt2dataname :: SymEnv -> DataDecl -> Builder.Builder+smt2dataname env (DDecl tc as _) = parenSeqs [name, n]+  where+    name  = smt2 env (symbol tc)+    n     = smt2 env as   -smt2datactors :: DataDecl -> SymM Builder-smt2datactors (DDecl _ as cs) =-  do ds <- traverse (smt2ctor as) cs-     if as > 0-      then do tvars <- traverse smt2TV [0..(as-1)]-              pure $ parenSeqs ["par", parens (smt2many tvars), parens (smt2many ds)]-      else pure $                                               parens (smt2many ds)+smt2datactors :: SymEnv -> DataDecl -> Builder.Builder+smt2datactors env (DDecl _ as cs) = parenSeqs ["par", parens tvars, parens ds]   where-    smt2TV = smt2 . SVar+    tvars        = smt2many (smt2TV <$> [0..(as-1)])+    smt2TV       = smt2 env . SVar+    ds           = smt2many (smt2ctor env as <$> cs)  -smt2ctor :: Int -> DataCtor -> SymM Builder-smt2ctor as (DCtor c fs) =-  do h <- smt2 c-     t <- traverse (smt2field as) fs-     pure $ parenSeqs (h : t)+smt2ctor :: SymEnv -> Int -> DataCtor -> Builder.Builder+smt2ctor env _  (DCtor c [])  = smt2 env c+smt2ctor env as (DCtor c fs)  = parenSeqs [smt2 env c, fields]+                                +  where+    fields                 = smt2many (smt2field env as <$> fs) -smt2field :: Int -> DataField -> SymM Builder-smt2field as d@(DField x t) =-  do s <- smt2 x-     ss <- smt2SortPoly d $ mkPoly as t-     pure $ parenSeqs [s , ss]+smt2field :: SymEnv -> Int -> DataField -> Builder.Builder+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.@@ -116,165 +97,122 @@     go is _        = is  instance SMTLIB2 Symbol where-  smt2 s = do env <- get-              case Thy.smt2Symbol env s of-                Just t  -> pure t-                Nothing -> pure $ symbolBuilder s-instance SMTLIB2 Int where-  smt2 i = pure $ Builder.fromString $ show i+  smt2 env s+    | Just t <- Thy.smt2Symbol env s = t+  smt2 _ s                           = symbolBuilder s +instance SMTLIB2 Int where +  smt2 _ = Builder.fromString . show + instance SMTLIB2 LocSymbol where-  smt2 = smt2 . val+  smt2 env = smt2 env . val  instance SMTLIB2 SymConst where-  smt2 c@(SL t) = do-    seStr <- gets seString-    if seStr-      then pure $ quotes $ fromText $ smtEscape t  -- emit "hello" not lit$36$hello-      else smt2 (symbol c)---- | Per https://smt-lib.org/theories-UnicodeStrings.shtml--- "SMT-LIB 2.6 has one escape sequence of its own for string literals. Two---  double quotes ("") are used to represent the double-quote character within---  a string literal"--smtEscape :: Text -> Text-smtEscape = T.replace "\"" "\"\""+  smt2 env = smt2 env . symbol  instance SMTLIB2 Constant where-  smt2 (I n)   = pure $ bShow n-  smt2 (R d)   = pure $ bFloat d-  smt2 (L t s)-    | isString s = pure $ quotes $ fromText t-    | otherwise  = pure $ fromText t+  smt2 _ (I n)   = bShow n+  smt2 _ (R d)   = bFloat d+  smt2 _ (L t _) = lbb t  instance SMTLIB2 Bop where-  smt2 Plus   = pure "+"-  smt2 Minus  = pure "-"-  smt2 Times  = pure $ symbolBuilder mulFuncName-  smt2 Div    = pure $ symbolBuilder divFuncName-  smt2 RTimes = pure "*"-  smt2 RDiv   = pure "/"-  smt2 Mod    = pure "mod"+  smt2 _ Plus   = "+"+  smt2 _ Minus  = "-"+  smt2 _ Times  = symbolBuilder mulFuncName+  smt2 _ Div    = symbolBuilder divFuncName+  smt2 _ RTimes = "*"+  smt2 _ RDiv   = "/"+  smt2 _ Mod    = "mod"  instance SMTLIB2 Brel where-  smt2 Eq  = pure "="-  smt2 Ueq = pure "="-  smt2 Gt  = pure ">"-  smt2 Ge  = pure ">="-  smt2 Lt  = pure "<"-  smt2 Le  = pure "<="-  smt2 _   = errorstar "SMTLIB2 Brel"+  smt2 _ Eq    = "="+  smt2 _ Ueq   = "="+  smt2 _ Gt    = ">"+  smt2 _ Ge    = ">="+  smt2 _ Lt    = "<"+  smt2 _ Le    = "<="+  smt2 _ _     = errorstar "SMTLIB2 Brel"  -- NV TODO: change the way EApp is printed instance SMTLIB2 Expr where-  smt2 (ESym z)         = smt2 z-  smt2 (ECon c)         = smt2 c-  smt2 (EVar x)         = smt2 x-  smt2 e@(EApp _ _)     = smt2App e-  smt2 (ENeg e)         = do s <- smt2 e-                             pure $ parenSeqs ["-", s]-  smt2 (EBin o e1 e2)   = do so <- smt2 o-                             s1 <- smt2 e1-                             s2 <- smt2 e2-                             pure $ parenSeqs [so, s1, s2]-  smt2 (ELet x e1 e2)   = do s1 <- smt2 (x, e1)-                             s2 <- smt2 e2-                             pure $ parenSeqs ["let", parens s1, s2]-  smt2 (EIte e1 e2 e3)  = do s1 <- smt2 e1-                             s2 <- smt2 e2-                             s3 <- smt2 e3-                             pure $ parenSeqs ["ite", s1, s2, s3]-  smt2 (ECst e t)       = smt2Cast e t-  smt2 PTrue            = pure "true"-  smt2 PFalse           = pure "false"-  smt2 (PAnd [])        = pure "true"-  smt2 (PAnd ps)        = do s <- smt2s ps-                             pure $ parenSeqs ["and", s]-  smt2 (POr [])         = pure "false"-  smt2 (POr ps)         = do s <- smt2s ps-                             pure $ parenSeqs ["or", s]-  smt2 (PNot p)         = do s <- smt2 p-                             pure $ parenSeqs ["not", s]-  smt2 (PImp p q)       = do s1 <- smt2 p-                             s2 <- smt2 q-                             pure $ parenSeqs ["=>", s1, s2]-  smt2 (PIff p q)       = do s1 <- smt2 p-                             s2 <- smt2 q-                             pure $ parenSeqs ["=", s1, s2]-  smt2 (PExist [] p)    = smt2 p-  smt2 (PExist xs p)    = do s <- smt2s xs-                             s1 <- smt2 p-                             pure $ parenSeqs ["exists", parens s, s1]-  smt2 (PAll   [] p)    = smt2 p-  smt2 (PAll   xs p)    = do s <- smt2s xs-                             s1 <- smt2 p-                             pure $ parenSeqs ["forall", parens s, s1]-  smt2 (PAtom r e1 e2)  = mkRel r e1 e2-  smt2 (ELam b e)       = smt2Lam b e-  smt2 (ECoerc t1 t2 e) = smt2Coerc t1 t2 e-  smt2 e                = panic ("smtlib2 Pred  " ++ show e)+  smt2 env (ESym z)         = smt2 env z+  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)         = 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 _   (PAnd [])        = "true"+  smt2 env (PAnd ps)        = parenSeqs ["and", smt2s env ps]+  smt2 _   (POr [])         = "false"+  smt2 env (POr ps)         = parenSeqs ["or", smt2s env ps] +  smt2 env (PNot p)         = parenSeqs ["not", smt2  env p]+  smt2 env (PImp p q)       = parenSeqs ["=>", smt2 env p, smt2 env q]+  smt2 env (PIff p q)       = parenSeqs ["=", smt2 env p, smt2 env q]+  smt2 env (PExist [] p)    = smt2 env p+  smt2 env (PExist bs p)    = parenSeqs ["exists", parens (smt2s env bs), smt2 env p]+  smt2 env (PAll   [] p)    = smt2 env p+  smt2 env (PAll   bs p)    = parenSeqs ["forall", parens (smt2s env bs), smt2 env p] +  smt2 env (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+  smt2 _   e                = panic ("smtlib2 Pred  " ++ show e) ++ -- | smt2Cast uses the 'as x T' pattern needed for polymorphic ADT constructors --   like Nil, see `tests/pos/adt_list_1.fq` -smt2Cast :: Expr -> Sort -> SymM Builder-smt2Cast (EVar x) t = smt2Var x t-smt2Cast e        _ = smt2    e+smt2Cast :: SymEnv -> Expr -> Sort -> Builder.Builder+smt2Cast env (EVar x) t = smt2Var env x t+smt2Cast env e        _ = smt2    env e -smt2Var :: Symbol -> Sort -> SymM Builder-smt2Var x t-  | isLamArgSymbol x = smtLamArg x t-  | otherwise        = do env <- get-                          case symEnvSort x env of-                            Just s | isPolyInst s t -> smt2VarAs x t-                            _                       -> smt2 x+smt2Var :: SymEnv -> Symbol -> Sort -> Builder.Builder+smt2Var env x t+  | isLamArgSymbol x            = smtLamArg env x t+  | Just s <- symEnvSort x env+  , isPolyInst s t              = smt2VarAs env x t+  | otherwise                   = smt2 env x -smt2VarAs :: Symbol -> Sort -> SymM Builder-smt2VarAs x t =-  do s <- smt2 x-     s1 <- smt2SortMono x t-     pure $ parenSeqs ["as", s, s1]+smtLamArg :: SymEnv -> Symbol -> Sort -> Builder.Builder+smtLamArg env x t = Builder.fromText $ symbolAtName x env () (FFunc t FInt) --- the next four functions (ones containing a call to `symbolAtName`) can trigger--- an expansion of the "nursery" tag table ('seApplsCur' in 'SymEnv') when processing--- a fresh function sort-smtLamArg :: Symbol -> Sort -> SymM Builder-smtLamArg x t =-  do s <- symbolAtName x (FFunc t FInt)-     pure $ Builder.fromText s+smt2VarAs :: SymEnv -> Symbol -> Sort -> Builder.Builder+smt2VarAs env x t = parenSeqs ["as", smt2 env x, smt2SortMono x env t] -smt2Lam :: (Symbol, Sort) -> Expr -> SymM Builder-smt2Lam (x, xT) full@(ECst _ eT) =-  do x' <- smtLamArg x xT-     lambda <- symbolAtName lambdaName (FFunc xT eT)-     f <- smt2 full-     pure $ parenSeqs [Builder.fromText lambda, x', f]-smt2Lam _ e+smt2Lam :: SymEnv -> (Symbol, Sort) -> Expr -> Builder.Builder+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)++smt2Lam _ _ e   = panic ("smtlib2: Cannot serialize unsorted lambda: " ++ showpp e) -smt2App :: Expr -> SymM Builder-smt2App (EApp (EApp f e1) e2)+smt2App :: SymEnv -> Expr -> Builder.Builder+smt2App env e@(EApp (EApp f e1) e2)   | Just t <- unApplyAt f-  = do a <- symbolAtName applyName t-       s <- smt2s [e1, e2]-       pure $ parenSeqs [Builder.fromText a, s]-smt2App e = do s0 <- traverse smt2 es-               s1 <- Thy.smt2App smt2VarAs f s0-               case s1 of-                 Just b -> pure b-                 Nothing -> do s2 <- smt2 f-                               s3 <- smt2s es-                               pure $ parenSeqs [s2, s3]+  = 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+  = parenSeqs [smt2 env f, smt2s env es]   where-    (f, es) = splitEApp' e+    (f, es)   = splitEApp' e -smt2Coerc :: Sort -> Sort -> Expr -> SymM Builder-smt2Coerc t1 t2 e-  | t1 == t2  = smt2 e-  | otherwise = do coerceFn <- symbolAtName coerceName (FFunc t1 t2)-                   s <- smt2 e-                   pure $ parenSeqs [Builder.fromText coerceFn , s]+smt2Coerc :: SymEnv -> Sort -> Sort -> Expr -> Builder.Builder+smt2Coerc env t1 t2 e +  | t1' == t2'  = 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+    t1'       = smt2SortMono e env t1 +    t2'       = smt2SortMono e env t2  splitEApp' :: Expr -> (Expr, [Expr]) splitEApp'            = go []@@ -283,77 +221,51 @@   --   go acc (ECst e _) = go acc e     go acc e          = (e, acc) -mkRel :: Brel -> Expr -> Expr -> SymM Builder-mkRel Ne  e1 e2 = mkNe e1 e2-mkRel Une e1 e2 = mkNe e1 e2-mkRel r   e1 e2 = do s <- smt2 r-                     s1 <- smt2 e1-                     s2 <- smt2 e2-                     pure $ parenSeqs [s, s1, s2]+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 = parenSeqs [smt2 env r, smt2 env e1, smt2 env e2] -mkNe :: Expr -> Expr -> SymM Builder-mkNe e1 e2 = do s1 <- smt2 e1-                s2 <- smt2 e2-                pure $ key "not" (parenSeqs ["=", s1, s2])-instance SMTLIB2 Command where-  smt2     (DeclData ds)       = do s <- smt2data ds-                                    pure $ key "declare-datatypes" s-  smt2     (Declare x ts t)    = do s <- smt2s ts-                                    s1 <- smt2 t-                                    pure $ parenSeqs ["declare-fun", Builder.fromText x, parens s, s1]-  smt2     c@(Define t)        = do s <- smt2SortMono c t-                                    pure $ key "declare-sort" s-  smt2     (DefineFunc name paramxs rsort e) =-    do n <- smt2 name-       bParams <- traverse (\(s, t) -> do s0 <- smt2 s-                                          s1 <- smt2 t-                                          pure $ parenSeqs [s0 , s1]) paramxs-       r <- smt2 rsort-       e' <- smt2 e-       pure $ parenSeqs ["define-fun", n, parenSeqs bParams, r, e']+mkNe :: SymEnv -> Expr -> Expr -> Builder.Builder+mkNe env e1 e2      = key "not" (parenSeqs ["=",  smt2 env e1, smt2 env e2]) -  smt2     (Assert Nothing p)  = {-# SCC "smt2-assert" #-}-                                  do s <- smt2 p-                                     pure $ key "assert" s-  smt2     (Assert (Just i) p) = {-# SCC "smt2-assert" #-}-                                  do s <- smt2 p-                                     pure $ key "assert" (parens ("!"<+> s <+> ":named p-" <> bShow i))-  smt2     (Distinct az)-    | length az < 2            = pure ""-    | otherwise                = do s <- smt2s az-                                    pure $ key "assert" $ key "distinct" s-  smt2     (AssertAx t)        = do s <- smt2 t-                                    pure $ key "assert" s-  smt2     Push                = pure "(push 1)"-  smt2     Pop                 = pure "(pop 1)"-  smt2     CheckSat            = pure "(check-sat)"-  smt2     (GetValue xs)       = do s <- smt2s xs-                                    pure $ key "key-value" (parens s)-  smt2     (CMany cmds)        = smt2s cmds-  smt2     Exit                = pure "(exit)"-  smt2     SetMbqi             = pure "(set-option :smt.mbqi true)"-  smt2     (Comment t)         = pure $ fromText ("; " <> t <> "\n")+instance SMTLIB2 Command where+  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                = 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)       = 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 (TR NoTrigger e)       = smt2 e-  smt2 (TR _ (PExist [] p))   = smt2 p-  smt2 t@(TR _ (PExist xs p)) = smtTr "exists" xs p t-  smt2 (TR _ (PAll   [] p))   = smt2 p-  smt2 t@(TR _ (PAll   xs p)) = smtTr "forall" xs p t-  smt2 (TR _ e)               = smt2 e-+  smt2 env (TR NoTrigger e)       = smt2 env e+  smt2 env (TR _ (PExist [] p))   = smt2 env p+  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)) = smtTr env "forall" bs p t+  smt2 env (TR _ e)               = smt2 env e+   {-# INLINE smtTr #-}-smtTr :: Builder -> [(Symbol, Sort)] -> Expr -> Triggered Expr -> SymM Builder-smtTr q xs p t =-  do s <- smt2s xs-     s1 <- smt2 p-     s2 <- smt2s (makeTriggers t)-     pure $ key q (parens s <+> key "!" (s1 <+> ":pattern" <> parens s2))+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 => [a] -> SymM Builder-smt2s as = smt2many <$> traverse smt2 as+smt2s    :: SMTLIB2 a => SymEnv -> [a] -> Builder.Builder+smt2s env as = smt2many (smt2 env <$> as)  {-# INLINE smt2many #-}-smt2many :: [Builder] -> Builder+smt2many :: [Builder.Builder] -> Builder.Builder smt2many = seqs
src/Language/Fixpoint/Smt/Theories.hs view
@@ -3,11 +3,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE ViewPatterns              #-}--{-# OPTIONS_GHC -Wno-orphans           #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE PatternGuards             #-}  module Language.Fixpoint.Smt.Theories      (@@ -30,26 +26,10 @@      , theorySymbols      , dataDeclSymbols -       -- * Theories-     , setEmpty, setEmp, setSng, setAdd, setMem, setCard-     , setCom, setCap, setCup, setDif, setSub -     , mapDef, mapSel, mapSto--     , bagEmpty, bagSng, bagCount, bagSub, bagCup, bagMax, bagMin--     -- * Z3 theory array encodings--     , arrConstM, arrStoreM, arrSelectM--     , arrConstS, arrStoreS, arrSelectS-     , arrMapNotS, arrMapOrS, arrMapAndS, arrMapImpS--     , arrConstB, arrStoreB, arrSelectB-     , arrMapPlusB, arrMapLeB, arrMapGtB, arrMapIteB--     -- * CVC5 finite fields-     , ffVal, ffAdd, ffMul+       -- * Theories+     , setEmpty, setEmp, setCap, setSub, setAdd, setMem+     , setCom, setCup, setDif, setSng, mapSel, mapCup, mapSto, mapDef        -- * Query Theories      , isSmt2App@@ -58,18 +38,20 @@      ) where  import           Prelude hiding (map)-import           Control.Monad.State-import           Data.ByteString.Builder (Builder)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif+ import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types import           Language.Fixpoint.Smt.Types -- import qualified Data.HashMap.Strict      as M import           Data.Maybe (catMaybes)+import qualified Data.Text.Lazy           as T -- import           Data.Text.Format import qualified Data.Text import           Data.String                 (IsString(..))-import Text.Printf (printf) import Language.Fixpoint.Utils.Builder  {- | [NOTE:Adding-Theories] To add new (SMTLIB supported) theories to@@ -82,68 +64,30 @@ -- | Theory Symbols ------------------------------------------------------------ -------------------------------------------------------------------------------- ----- Size changes-bvConcatName, bvExtractName, bvRepeatName, bvZeroExtName, bvSignExtName :: Symbol-bvConcatName   = "concat"-bvExtractName  = "extract"-bvRepeatName   = "repeat"-bvZeroExtName  = "zero_extend"-bvSignExtName  = "sign_extend"+-- "set" is currently \"LSet\" instead of just \"Set\" because Z3 has its own+-- \"Set\" since 4.8.5+elt, set, map :: Raw+elt  = "Elt"+set  = "LSet"+map  = "Map" --- Unary Logic-bvNotName, bvNegName :: Symbol-bvNotName = "bvnot"-bvNegName = "bvneg"+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"+mem   = "smt_set_mem"+dif   = "smt_set_dif"+sub   = "smt_set_sub"+com   = "smt_set_com"+sel   = "smt_map_sel"+sto   = "smt_map_sto"+mcup  = "smt_map_cup"+mdef  = "smt_map_def" --- Binary Logic-bvAndName, bvNandName, bvOrName, bvNorName, bvXorName, bvXnorName :: Symbol-bvAndName  = "bvand"-bvNandName = "bvnand"-bvOrName   = "bvor"-bvNorName  = "bvnor"-bvXorName  = "bvxor"-bvXnorName = "bvxnor" --- Shifts-bvShlName, bvLShrName, bvAShrName, bvLRotName, bvRRotName :: Symbol-bvShlName  = "bvshl"-bvLShrName = "bvlshr"-bvAShrName = "bvashr"-bvLRotName = "rotate_left"-bvRRotName = "rotate_right"---- Arithmetic-bvAddName, bvSubName, bvMulName, bvUDivName :: Symbol-bvURemName, bvSDivName, bvSRemName, bvSModName :: Symbol-bvAddName  = "bvadd"-bvSubName  = "bvsub"-bvMulName  = "bvmul"-bvUDivName = "bvudiv"-bvURemName = "bvurem"-bvSDivName = "bvsdiv"-bvSRemName = "bvsrem"-bvSModName = "bvsmod"---- Comparisons-bvCompName, bvULtName, bvULeName, bvUGtName, bvUGeName :: Symbol-bvSLtName, bvSLeName, bvSGtName, bvSGeName :: Symbol-bvCompName = "bvcomp"-bvULtName  = "bvult"-bvULeName  = "bvule"-bvUGtName  = "bvugt"-bvUGeName  = "bvuge"-bvSLtName  = "bvslt"-bvSLeName  = "bvsle"-bvSGtName  = "bvsgt"-bvSGeName  = "bvsge"--mapDef, mapSel, mapSto :: (IsString a) => a-mapDef   = "Map_default"-mapSel   = "Map_select"-mapSto   = "Map_store"--setCard, setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: (IsString a) => a-setCard  = "Set_card"+setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: Symbol setEmpty = "Set_empty" setEmp   = "Set_emp" setCap   = "Set_cap"@@ -155,183 +99,195 @@ setDif   = "Set_dif" setSng   = "Set_sng" -bagEmpty, bagSng, bagCount, bagSub, bagCup, bagMax, bagMin :: (IsString a) => a-bagEmpty = "Bag_empty"-bagSng   = "Bag_sng"-bagCount = "Bag_count"-bagSub   = "Bag_sub"-bagCup   = "Bag_union"-bagMax   = "Bag_union_max" -- See [Bag max and min]-bagMin   = "Bag_inter_min"---- [Bag max and min]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Functions bagMax and bagMin: Union/intersect two bags, combining the elements by--- taking either the greatest (bagMax) or the least (bagMin) of them.---   bagMax, bagMin : Map v Int -> Map v Int -> Map v Int----- Array operations for polymorphic maps-arrConstM, arrStoreM, arrSelectM :: Symbol-arrConstM  = "arr_const_m"-arrStoreM  = "arr_store_m"-arrSelectM = "arr_select_m"----- Array operations for sets (Z3)-arrConstS, arrStoreS, arrSelectS, arrMapNotS, arrMapOrS, arrMapAndS, arrMapImpS :: Symbol-arrConstS  = "arr_const_s"-arrStoreS  = "arr_store_s"-arrSelectS = "arr_select_s"--arrMapNotS = "arr_map_not"-arrMapOrS  = "arr_map_or"-arrMapAndS = "arr_map_and"-arrMapImpS = "arr_map_imp"----- Array operations for bags (Z3)-arrConstB, arrStoreB, arrSelectB :: Symbol-arrConstB  = "arr_const_b"-arrStoreB  = "arr_store_b"-arrSelectB = "arr_select_b"--arrMapPlusB, arrMapLeB, arrMapGtB, arrMapIteB :: Symbol-arrMapPlusB = "arr_map_plus"-arrMapLeB   = "arr_map_le"-arrMapGtB   = "arr_map_gt"-arrMapIteB   = "arr_map_ite"---- Finite field operations-ffVal, ffAdd, ffMul :: (IsString a) => a -- Symbol-ffVal = "FF_val"-ffAdd = "FF_add"-ffMul = "FF_mul"+mapSel, mapSto, mapCup, mapDef :: Symbol+mapSel   = "Map_select"+mapSto   = "Map_store"+mapCup   = "Map_union"+mapDef   = "Map_default" -strLen, strSubstr, strConcat, strConcat', strPrefixOf, strSuffixOf, strContains :: (IsString a) => a -- Symbol+strLen, strSubstr, strConcat :: (IsString a) => a -- Symbol strLen    = "strLen" strSubstr = "subString" strConcat = "concatString"-strConcat' = "strConcat"-strPrefixOf  = "strPrefixOf"-strSuffixOf = "strSuffixOf"-strContains = "strContains" -smtlibStrLen, smtlibStrSubstr, smtlibStrConcat, smtlibStrPrefixOf, smtlibStrSuffixOf, smtlibStrContains :: Raw-smtlibStrLen    = "str.len"-smtlibStrSubstr = "str.substr"-smtlibStrConcat = "str.++"-smtlibStrPrefixOf = "str.prefixof"-smtlibStrSuffixOf = "str.suffixof"-smtlibStrContains = "str.contains"+z3strlen, z3strsubstr, z3strconcat :: Raw+z3strlen    = "str.len"+z3strsubstr = "str.substr"+z3strconcat = "str.++" -strLenSort, substrSort, concatstrSort, strCompareSort :: Sort+strLenSort, substrSort, concatstrSort :: Sort strLenSort    = FFunc strSort intSort substrSort    = mkFFunc 0 [strSort, intSort, intSort, strSort] concatstrSort = mkFFunc 0 [strSort, strSort, strSort]-strCompareSort = mkFFunc 0 [strSort, strSort, boolSort]  string :: Raw string = strConName -bFun :: Raw -> [(Builder, Builder)] -> Builder -> Builder -> Builder-bFun name xts out body = key "define-fun" (seqs [fromText name, args, out, body])+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 -> Builder-bFun' name ts out = key "declare-fun" (seqs [fromText name, args, out])+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 -> Builder-bSort name def = key "define-sort" (fromText name <+> "()" <+> def)+bSort :: Raw -> Builder -> T.Text+bSort name def = blt $ key "define-sort" (bb name <+> "()" <+> def) +z3Preamble :: Config -> [T.Text]+z3Preamble u+  = stringPreamble u +++    [ 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 -> Data.Text.Text -> Builder+uifDef :: Config -> T.Text -> T.Text -> T.Text uifDef cfg f op-  | onlyLinearArith cfg -- linear cfg || Z3 /= solver cfg-  = bFun' f ["Int", "Int"] "Int"+  | linear cfg || Z3 /= solver cfg+  = bFun' f ["Int", "Int"] "Int"    | otherwise-  = bFun f [("x", "Int"), ("y", "Int")] "Int" (key2 (fromText op) "x" "y")--onlyLinearArith :: Config -> Bool-onlyLinearArith cfg = linear cfg || solver cfg `notElem` [Z3, Z3mem, Cvc5]--preamble :: Config -> SMTSolver -> [Builder]-preamble cfg s = snd <$> filter (matchesCondition s . fst) (solverPreamble cfg)---matchesCondition :: SMTSolver -> PreambleCondition -> Bool-matchesCondition _ SAll       = True-matchesCondition s (SOnly ss) = s `elem` ss--solverPreamble :: Config -> [Preamble]-solverPreamble cfg-  =  [ (SOnly [Z3, Z3mem],  "(set-option :auto-config false)")-     , (SOnly [Z3, Z3mem],  "(set-option :model true)")-     , (SOnly [Cvc4],       "(set-logic ALL_SUPPORTED)")-     , (SOnly [Cvc5],       "(set-logic ALL)")-     , (SOnly [Cvc4, Cvc5], "(set-option :incremental true)")-     ]-  ++ setPreamble cfg-  ++ boolPreamble cfg-  ++ arithPreamble cfg-  ++ stringPreamble cfg--type Preamble = (PreambleCondition, Builder)+  = bFun f [("x", "Int"), ("y", "Int")] "Int" (key2 (bb op) "x" "y") -data PreambleCondition = SAll | SOnly [SMTSolver]-  deriving (Eq, Show)+cvc4Preamble :: Config -> [T.Text]+cvc4Preamble z+  = [        "(set-logic ALL_SUPPORTED)"]+  ++ commonPreamble z+  ++ cvc4MapPreamble z -setPreamble :: Config -> [Preamble]--- Z3 does not support cardinality on sets, which is defined to be uninterpreted function-setPreamble _-  = [ (SOnly [Z3, Z3mem],  bFun' "set.card" ["(Array Int Bool)"] "Int") ]+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)"+    ] -boolPreamble :: Config -> [Preamble]-boolPreamble _-  = [ (SAll, bFun boolToIntName [("b", "Bool")] "Int" "(ite b 1 0)") ]+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)"+    ] -arithPreamble :: Config -> [Preamble]-arithPreamble cfg = (SAll,) <$>- [ uifDef cfg (symbolText mulFuncName) "*"- , uifDef cfg (symbolText divFuncName) "div"- ]+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 -> [Preamble]-stringPreamble cfg | not (noStringTheory cfg)-  = [ (SAll, bSort string "String")-    , (SAll, bFun strLen [("s", fromText string)] "Int" (key (fromText smtlibStrLen) "s"))-    , (SAll, bFun strSubstr [("s", fromText string), ("i", "Int"), ("j", "Int")] (fromText string) (key (fromText smtlibStrSubstr) "s i j"))-    , (SAll, bFun strConcat [("x", fromText string), ("y", fromText string)] (fromText string) (key (fromText smtlibStrConcat) "x y"))+stringPreamble :: Config -> [T.Text]+stringPreamble cfg | stringTheory cfg+  = [ 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 _-  = [ (SAll, bSort string "Int")-    , (SAll, bFun' strLen [fromText string] "Int")-    , (SAll, bFun' strSubstr [fromText string, "Int", "Int"] (fromText string))-    , (SAll, bFun' strConcat [fromText string, fromText string] (fromText 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-smt2Symbol env x = fromText . tsRaw <$> symEnvTheory x env+smt2Symbol env x = fromLazyText . tsRaw <$> symEnvTheory x env  instance SMTLIB2 SmtSort where-  smt2 s = pure $ smt2SmtSort s+  smt2 _ = smt2SmtSort  smt2SmtSort :: SmtSort -> Builder smt2SmtSort SInt         = "Int" smt2SmtSort SReal        = "Real" smt2SmtSort SBool        = "Bool"-smt2SmtSort SString      = fromText string-smt2SmtSort (SSet a)     = key "Set" (smt2SmtSort a)-smt2SmtSort (SBag a)     = key "Bag" (smt2SmtSort a)-smt2SmtSort (SArray a b) = key2 "Array" (smt2SmtSort a) (smt2SmtSort b)-smt2SmtSort (SFFld n)    = key "_ FiniteField" (bShow 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@@ -342,45 +298,31 @@ smt2SmtSorts :: [SmtSort] -> Builder smt2SmtSorts = seqs . fmap smt2SmtSort -type VarAs = Symbol -> Sort -> SymM Builder+type VarAs = SymEnv -> Symbol -> Sort -> Builder ---------------------------------------------------------------------------------smt2App :: VarAs -> Expr -> [Builder] -> SymM (Maybe Builder)+smt2App :: VarAs -> SymEnv -> Expr -> [Builder] -> Maybe Builder ---------------------------------------------------------------------------------smt2App _ ex@(dropECst -> EVar f) [d]-  | f == arrConstS || f == arrConstB || f == arrConstM =-      do env <- get-         pure $ Just $ key (key "as const" (getTarget env ex)) d-  | f == setEmpty  =-      do env <- get-         pure $ Just $ key "as set.empty" (getTarget env ex)-  | f == bagEmpty  =-      do env <- get-         pure $ Just $ key "as bag.empty" (getTarget env ex)-  | f == ffVal  =-      do env <- get-         pure $ Just $ key ("as ff" <> d) (getTarget env ex)-  where-    getTarget :: SymEnv -> Expr -> Builder-    -- const is a function, but SMT expects only the output sort-    getTarget env (ECst _ t) = smt2SmtSort $ sortSmtSort True (seData env) (ffuncOut t)-    getTarget _ e = bShow e+smt2App _ _ (ECst (EVar f) _) [d]+  | f == setEmpty = Just (bb emp)+  | f == setEmp   = Just (key2 "=" (bb emp) d)+  | f == setSng   = Just (key (bb sng) d) -- Just (key2 (bb add) (bb emp) d) -smt2App k ex (builder:builders) =-  do a <- smt2AppArg k ex-     pure $ (\fb -> key fb (builder <> mconcat [ " " <> d | d <- builders])) <$> a-smt2App _ _ [] = pure Nothing+smt2App k env f (d:ds)+  | Just fb <- smt2AppArg k env f+  = Just $ key fb (d <> mconcat [ " " <> d | d <- ds]) -smt2AppArg :: VarAs -> Expr -> SymM (Maybe Builder)-smt2AppArg k (ECst (dropECst -> EVar f) t)-  = do env <- get-       case symEnvTheory f env of-         Just fThy -> if isPolyCtor fThy t-                           then Just <$> k f (ffuncOut t)-                           else pure $ Just $ fromText (tsRaw fThy)-         Nothing   -> pure Nothing-smt2AppArg _ _-  = pure Nothing+smt2App _ _ _ _    = Nothing +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 bb (tsRaw fThy)++smt2AppArg _ _ _+  = Nothing+ isPolyCtor :: TheorySymbol -> Sort -> Bool isPolyCtor fThy t = isPolyInst (tsSort fThy) t && tsInterp fThy == Ctor @@ -390,8 +332,12 @@ -------------------------------------------------------------------------------- isSmt2App :: SEnv TheorySymbol -> Expr -> Maybe Int ---------------------------------------------------------------------------------isSmt2App g (dropECst -> EVar f) = lookupSEnv f g >>= thyAppInfo-isSmt2App _  _                   = Nothing+isSmt2App g  (EVar f)+  | f == setEmpty = Just 1+  | f == setEmp   = Just 1+  | f == setSng   = Just 1+  | otherwise     = lookupSEnv f g >>= thyAppInfo+isSmt2App _ _     = Nothing  thyAppInfo :: TheorySymbol -> Maybe Int thyAppInfo ti = case tsInterp ti of@@ -403,7 +349,10 @@   Just (_, ts) -> Just (length ts - 1)   Nothing      -> Nothing -+preamble :: Config -> SMTSolver -> [T.Text]+preamble u Z3   = z3Preamble u+preamble u Cvc4 = cvc4Preamble u+preamble u _    = smtlibPreamble u  -------------------------------------------------------------------------------- -- | Theory Symbols : `uninterpSEnv` should be disjoint from see `interpSEnv`@@ -411,300 +360,67 @@ --   symbols, and `interpSEnv` is for interpreted symbols. -------------------------------------------------------------------------------- -instance TheorySymbols SMTSolver where-  theorySymbols :: SMTSolver -> SEnv TheorySymbol-  theorySymbols = fromListSEnv . interpSymbols--instance TheorySymbols [DataDecl] where-  theorySymbols :: [DataDecl] -> SEnv TheorySymbol-  theorySymbols = fromListSEnv . concatMap dataDeclSymbols+-- | `theorySymbols` contains the list of ALL SMT symbols with interpretations,+--   i.e. which are given via `define-fun` (as opposed to `declare-fun`)+theorySymbols :: [DataDecl] -> SEnv TheorySymbol -- M.HashMap Symbol TheorySymbol+theorySymbols ds = fromListSEnv $  -- SHIFTLAM uninterpSymbols+                                  interpSymbols+                               ++ concatMap dataDeclSymbols ds  -instance TheorySymbols [Equation] where-  theorySymbols = fromListSEnv . fmap equationSymbol--instance TheorySymbols DefinedFuns where-  theorySymbols (MkDefinedFuns eqns) = theorySymbols eqns--equationSymbol :: Equation -> (Symbol, TheorySymbol)-equationSymbol eq = (sym, Thy sym (symbolRaw sym) sort Defined)-  where-    sym  = eqName eq-    sort = mkFFunc 0 ((snd <$> eqArgs eq) <> [eqSort eq])- ---------------------------------------------------------------------------------interpSymbols :: SMTSolver -> [(Symbol, TheorySymbol)]+interpSymbols :: [(Symbol, TheorySymbol)] ---------------------------------------------------------------------------------interpSymbols cfg =-  [-    -- maps--    interpSym mapDef   mapDef  mapDefSort-  , interpSym mapSel   mapSel  mapSelSort-  , interpSym mapSto   mapSto  mapStoSort--  , interpSym arrConstM  "const"  (FAbs 0 $ FFunc (FVar 1) mapArrSort)-  , interpSym arrSelectM "select" (FAbs 0 $ FFunc mapArrSort $ FFunc (FVar 0) (FVar 1))-  , interpSym arrStoreM  "store"  (FAbs 0 $ FFunc mapArrSort $ FFunc (FVar 0) $ FFunc (FVar 1) mapArrSort)--  -- CVC5 sets--  , interpSym setCard  "set.card"       (FAbs 0 $ FFunc (setSort $ FVar 0) intSort)-  , interpSym setEmp   "set.is_empty"   (FAbs 0 $ FFunc (setSort $ FVar 0) boolSort)-  , interpSym setEmpty "set.empty"      (FAbs 0 $ FFunc intSort (setSort $ FVar 0))-  , interpSym setSng   "set.singleton"  (FAbs 0 $ FFunc (FVar 0) (setSort $ FVar 0))-  , interpSym setAdd   "set.insert"     (FAbs 0 $ FFunc (FVar 0) $ FFunc (setSort $ FVar 0) (setSort $ FVar 0))-  , interpSym setMem   "set.member"     (FAbs 0 $ FFunc (FVar 0) $ FFunc (setSort $ FVar 0) boolSort)-  , interpSym setCup   "set.union"      setBopSort-  , interpSym setCap   "set.inter"      setBopSort-  , interpSym setDif   "set.minus"      setBopSort-  , interpSym setSub   "set.subset"     (FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (setSort $ FVar 0) boolSort)-  , interpSym setCom   "set.complement" (FAbs 0 $ FFunc (setSort $ FVar 0) (setSort $ FVar 0))--  -- CVC5 bags--  , interpSym bagEmpty "bag.empty"          (FAbs 0 $ FFunc intSort (bagSort $ FVar 0))-  , interpSym bagSng   "bag"                (FAbs 0 $ FFunc (FVar 0) $ FFunc intSort (bagSort $ FVar 0))-  , interpSym bagCount "bag.count"          (FAbs 0 $ FFunc (FVar 0) $ FFunc (bagSort $ FVar 0) intSort)-  , interpSym bagCup   "bag.union_disjoint" bagBopSort-  , interpSym bagMax   "bag.union_max"      bagBopSort-  , interpSym bagMin   "bag.inter_min"      bagBopSort-  , interpSym bagSub   "bag.subbag"         (FAbs 0 $ FFunc (bagSort $ FVar 0) $ FFunc (bagSort $ FVar 0) boolSort)--  -- Strings-  , interpSym strLen     strLen    strLenSort-  , interpSym strSubstr  strSubstr substrSort-  , interpSym strConcat  strConcat concatstrSort-  , interpSym strConcat' smtlibStrConcat concatstrSort-  , interpSym strPrefixOf smtlibStrPrefixOf strCompareSort-  , interpSym strSuffixOf smtlibStrSuffixOf strCompareSort-  , interpSym strContains smtlibStrContains strCompareSort-+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+  , interpSym setMem   mem   setMemSort+  , interpSym setDif   dif   setBopSort+  , interpSym setSub   sub   setCmpSort+  , interpSym setCom   com   setCmpSort+  , interpSym mapSel   sel   mapSelSort+  , interpSym mapSto   sto   mapStoSort+  , interpSym mapCup   mcup  mapCupSort+  , interpSym mapDef   mdef  mapDefSort+  , interpSym bvOrName "bvor"   bvBopSort+  , interpSym bvAndName "bvand" bvBopSort+  , interpSym strLen    strLen    strLenSort+  , interpSym strSubstr strSubstr substrSort+  , interpSym strConcat strConcat concatstrSort   , interpSym boolInt   boolInt   (FFunc boolSort intSort)--  -- Function mappings for indexed identifier functions-  , interpSym' "_" iiSort-  , interpSym "app" "" appSort--  , interpSym' bvConcatName bvConcatSort-  , interpSym' bvExtractName (FFunc FInt bvExtendSort)-  , interpBvExt bvRepeatName-  , interpBvExt bvZeroExtName-  , interpBvExt bvSignExtName--  , interpBvUop bvNotName-  , interpBvUop bvNegName--  , interpBvBop bvAndName-  , interpBvBop bvNandName-  , interpBvBop bvOrName-  , interpBvBop bvNorName-  , interpBvBop bvXorName-  , interpBvBop bvXnorName--  , interpBvBop bvShlName-  , interpBvBop bvLShrName-  , interpBvBop bvAShrName-  , interpBvRot bvLRotName-  , interpBvRot bvRRotName--  , interpBvBop bvAddName-  , interpBvBop bvSubName-  , interpBvBop bvMulName-  , interpBvBop bvUDivName-  , interpBvBop bvURemName-  , interpBvBop bvSDivName-  , interpBvBop bvSRemName-  , interpBvBop bvSModName--  , interpSym' bvCompName bvEqSort-  , interpBvCmp bvULtName-  , interpBvCmp bvULeName-  , interpBvCmp bvUGtName-  , interpBvCmp bvUGeName-  , interpBvCmp bvSLtName-  , interpBvCmp bvSLeName-  , interpBvCmp bvSGtName-  , interpBvCmp bvSGeName--  -- int to bv Conversions--  , interpSym intbv32Name   "(_ int2bv 32)" (FFunc intSort bv32)-  , interpSym intbv64Name   "(_ int2bv 64)" (FFunc intSort bv64)-  , interpSym bv32intName   (bv2i cfg 32)   (FFunc bv32    intSort)-  , interpSym bv64intName   (bv2i cfg 64)   (FFunc bv64    intSort)--  , interpSym intbv8Name    "(_ int2bv 8)"  (FFunc intSort bv8)-  , interpSym intbv16Name   "(_ int2bv 16)" (FFunc intSort bv16)-  , interpSym bv8intName    (bv2i cfg 32)   (FFunc bv8    intSort)-  , interpSym bv16intName   (bv2i cfg 64)   (FFunc bv16    intSort)   ]-  ++-  if cfg == Z3 || cfg == Z3mem-  then-  [-    -- Z3 sets (arrays of bools)--    interpSym arrConstS  "const"  (FAbs 0 $ FFunc boolSort setArrSort)-  , interpSym arrSelectS "select" (FAbs 0 $ FFunc setArrSort $ FFunc (FVar 0) boolSort)-  , interpSym arrStoreS  "store"  (FAbs 0 $ FFunc setArrSort $ FFunc (FVar 0) $ FFunc boolSort setArrSort)--  , interpSym arrMapNotS "(_ map not)" (FAbs 0 $ FFunc setArrSort setArrSort)-  , interpSym arrMapOrS  "(_ map or)"  (FAbs 0 $ FFunc setArrSort $ FFunc setArrSort setArrSort)-  , interpSym arrMapAndS "(_ map and)" (FAbs 0 $ FFunc setArrSort $ FFunc setArrSort setArrSort)-  , interpSym arrMapImpS "(_ map =>)"  (FAbs 0 $ FFunc setArrSort $ FFunc setArrSort setArrSort)--    -- Z3 bags (arrays of ints)--  , interpSym arrConstB  "const"  (FAbs 0 $ FFunc intSort bagArrSort)-  , interpSym arrSelectB "select" (FAbs 0 $ FFunc bagArrSort $ FFunc (FVar 0) intSort)-  , interpSym arrStoreB  "store"  (FAbs 0 $ FFunc bagArrSort $ FFunc (FVar 0) $ FFunc intSort bagArrSort)--  , interpSym arrMapPlusB "(_ map (+ (Int Int) Int))"        (FAbs 0 $ FFunc bagArrSort $ FFunc bagArrSort bagArrSort)-  , interpSym arrMapLeB   "(_ map (<= (Int Int) Bool))"      (FAbs 0 $ FFunc bagArrSort $ FFunc bagArrSort setArrSort)-  , interpSym arrMapGtB   "(_ map (> (Int Int) Bool))"       (FAbs 0 $ FFunc bagArrSort $ FFunc bagArrSort setArrSort)-  , interpSym arrMapIteB  "(_ map (ite (Bool Int Int) Int))" (FAbs 0 $ FFunc setArrSort $ FFunc bagArrSort $ FFunc bagArrSort bagArrSort)-  ] else if cfg == Cvc5-  then-  [-    -- CVC5 finite fields--    interpSym ffVal ffVal     (FAbs 0 $ FFunc intSort (finfieldSort (FVar 0)))-  , interpSym ffAdd "ff.add" (FAbs 0 $ FFunc (finfieldSort (FVar 0)) $ FFunc (finfieldSort (FVar 0)) (finfieldSort (FVar 0)))-  , interpSym ffMul "ff.mul" (FAbs 0 $ FFunc (finfieldSort (FVar 0)) $ FFunc (finfieldSort (FVar 0)) (finfieldSort (FVar 0)))-  ] else []   where--    mapArrSort = arraySort (FVar 0) (FVar 1)-    setArrSort = arraySort (FVar 0) boolSort-    bagArrSort = arraySort (FVar 0) intSort-    bv8        = sizedBitVecSort "Size8"-    bv16       = sizedBitVecSort "Size16"-    bv32       = sizedBitVecSort "Size32"-    bv64       = sizedBitVecSort "Size64"     boolInt    = boolToIntName--    mapDefSort = FAbs 0 $ FAbs 1 $ FFunc (FVar 1)-                                         (mapSort (FVar 0) (FVar 1))-    -- select :: forall k v. Map k v -> k -> v+    setAddSort = FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (FVar 0)           (setSort $ FVar 0)+    setBopSort = FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (setSort $ FVar 0) (setSort $ FVar 0)+    setMemSort = FAbs 0 $ FFunc (FVar 0) $ FFunc (setSort $ FVar 0) boolSort+    setCmpSort = FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (setSort $ FVar 0) boolSort     mapSelSort = FAbs 0 $ FAbs 1 $ FFunc (mapSort (FVar 0) (FVar 1))                                  $ FFunc (FVar 0) (FVar 1)-    -- store :: forall k v. Map k v -> k -> v -> Map k v+    mapCupSort = FAbs 0          $ FFunc (mapSort (FVar 0) intSort)+                                 $ FFunc (mapSort (FVar 0) intSort)+                                         (mapSort (FVar 0) intSort)     mapStoSort = FAbs 0 $ FAbs 1 $ FFunc (mapSort (FVar 0) (FVar 1))                                  $ FFunc (FVar 0)                                  $ FFunc (FVar 1)                                          (mapSort (FVar 0) (FVar 1))--    setBopSort = FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (setSort $ FVar 0) (setSort $ FVar 0)-    bagBopSort = FAbs 0 $ FFunc (bagSort $ FVar 0) $ FFunc (bagSort $ FVar 0) (bagSort $ FVar 0)--bv2i :: SMTSolver -> Int -> Raw-bv2i Cvc4 _ = "bv2nat"-bv2i Cvc5 _ = "bv2nat"-bv2i _    n = Data.Text.pack $ printf "(_ bv2nat %d)" n--interpBvUop :: Symbol -> (Symbol, TheorySymbol)-interpBvUop name = interpSym' name bvUopSort-interpBvBop :: Symbol -> (Symbol, TheorySymbol)-interpBvBop name = interpSym' name bvBopSort-interpBvCmp :: Symbol -> (Symbol, TheorySymbol)-interpBvCmp name = interpSym' name bvCmpSort-interpBvExt :: Symbol -> (Symbol, TheorySymbol)-interpBvExt name = interpSym' name bvExtendSort-interpBvRot :: Symbol -> (Symbol, TheorySymbol)-interpBvRot name = interpSym' name bvRotSort--interpSym' :: Symbol -> Sort -> (Symbol, TheorySymbol)-interpSym' name = interpSym name (Data.Text.pack $ symbolString name)---- Indexed Identifier sort.--- Together with 'app', this allows one to write indexed identifier--- functions (smtlib2 specific functions). (e.g. ((_ sign_extend 1) bv))------ The idea here is that 'app' is elaborated to the empty string,--- and '_' does the typelit application as it does in smtlib2.------ Then if we write, (app (_ sign_extend 1) bv), LF will elaborate--- it as ( (_ sign_extend 1) bv). Fitting the smtlib2 format exactly!------ One thing to note, is that any indexed identifier function (like--- sign_extend) has to have no FAbs in it. Otherwise, they will be--- elaborated like e.g. ( (_ (as sign_extend Int) 1) bv), which is wrong!------ _ :: forall a b c. (a -> b -> c) -> a -> (b -> c)-iiSort :: Sort-iiSort = FAbs 0 $ FAbs 1 $ FAbs 2 $ FFunc-               (FFunc (FVar 0) $ FFunc (FVar 1) (FVar 2))-               (FFunc (FVar 0) $ FFunc (FVar 1) (FVar 2))---- Simple application, used for indexed identifier function, check '_'.------ app :: forall a b. (a -> b) -> a -> b-appSort :: Sort-appSort = FAbs 0 $ FAbs 1 $ FFunc-                (FFunc (FVar 0) (FVar 1))-                (FFunc (FVar 0) (FVar 1))---- Indexed identifier operation, purposely didn't place FAbs!------ extend :: Int -> BitVec a -> BitVec b-bvExtendSort :: Sort-bvExtendSort  = FFunc FInt $ FFunc (bitVecSort 1) (bitVecSort 2)---- Indexed identifier operation, purposely didn't place FAbs!------ rot :: Int -> BitVec a -> BitVec a-bvRotSort :: Sort-bvRotSort  = FFunc FInt $ FFunc (bitVecSort 0) (bitVecSort 0)---- uOp :: forall a. BitVec a -> BitVec a-bvUopSort :: Sort-bvUopSort = FAbs 0 $ FFunc (bitVecSort 0) (bitVecSort 0)---- bOp :: forall a. BitVec a -> BitVec a -> BitVec a-bvBopSort :: Sort-bvBopSort = FAbs 0 $ FFunc (bitVecSort 0) $ FFunc (bitVecSort 0) (bitVecSort 0)--- bvBopSort = FAbs 0 $ FFunc (bitVecSort (FVar 0)) (FFunc (bitVecSort (FVar 0)) (bitVecSort (FVar 0)))---- cmp :: forall a. BitVec a -> BitVec a -> Bool-bvCmpSort :: Sort-bvCmpSort = FAbs 0 $ FFunc (bitVecSort 0) $ FFunc (bitVecSort 0) boolSort---- eq :: forall a. BitVec a -> BitVec a -> BitVec 1-bvEqSort :: Sort-bvEqSort = FAbs 0 $ FFunc (bitVecSort 0) $ FFunc (bitVecSort 0) (sizedBitVecSort "Size1")+    mapDefSort = FAbs 0 $ FAbs 1 $ FFunc (FVar 1)+                                         (mapSort (FVar 0) (FVar 1)) --- concat :: forall a b c. BitVec a -> BitVec b -> BitVec c-bvConcatSort :: Sort-bvConcatSort = FAbs 0 $ FAbs 1 $ FAbs 2 $-                     FFunc (bitVecSort 0) $ FFunc (bitVecSort 1) (bitVecSort 2)+    bvBopSort  = FFunc bitVecSort $ FFunc bitVecSort bitVecSort  interpSym :: Symbol -> Raw -> Sort -> (Symbol, TheorySymbol) interpSym x n t = (x, Thy x n t Theory) --- This variable is used to generate the lambda names `lam_arg$n` in--- `Interface.hs` that will be used during defunctionalization in--- `Defunctionalize.hs`, is a pretty gross hack as if the user types in the--- program or PLE generates a term that has more than `maxLamArg` lambda binders--- one inside the other, the SMT will crash complaining that--- `lam_arg${maxLamArg + k}` was not declared. maxLamArg :: Int-maxLamArg = 20--axiomLiterals :: Config -> [(Symbol, Sort)] -> [Expr]-axiomLiterals cfg-  | noStringTheory cfg = lenAxiomLiterals-  | otherwise          = strAxiomLiterals--strAxiomLiterals :: [(Symbol, Sort)] -> [Expr]-strAxiomLiterals lts = catMaybes [ strAxiom l | (l, t) <- lts, isString t ]-  where-    strAxiom l = do-      sym <- unLitSymbol l-      pure (EEq (expr l) (ECon $ L (symbolText sym) strSort))+maxLamArg = 7 -lenAxiomLiterals :: [(Symbol, Sort)] -> [Expr]-lenAxiomLiterals lts = catMaybes [ lenAxiom l <$> litLen l | (l, t) <- lts, isString t ]+axiomLiterals :: [(Symbol, Sort)] -> [Expr]+axiomLiterals lts = catMaybes [ lenAxiom l <$> litLen l | (l, t) <- lts, isString t ]   where     lenAxiom l n  = EEq (EApp (expr (strLen :: Symbol)) (expr l)) (expr n `ECst` intSort)     litLen        = fmap (Data.Text.length .  symbolText) . unLitSymbol@@ -755,8 +471,8 @@     sx         = testSymbol x     raw        = "is-" <> symbolRaw x -symbolRaw :: Symbol -> Data.Text.Text-symbolRaw = symbolSafeText+symbolRaw :: Symbol -> T.Text+symbolRaw = T.fromStrict . symbolSafeText  -------------------------------------------------------------------------------- selectSymbols :: DataDecl -> [(Symbol, TheorySymbol)]
src/Language/Fixpoint/Smt/Types.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE TupleSections             #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE UndecidableInstances      #-} - -- | This module contains the types defining an SMTLIB2 interface.  module Language.Fixpoint.Smt.Types (@@ -26,23 +24,17 @@     -- * SMTLIB2 Process Context     , Context (..) -    -- * SMT monad-    , SmtM-    , liftSym-    , catchSMT-    , bracketSMT-     ) where-import           Control.Exception-import           Control.Monad.State-import           Data.ByteString.Builder (Builder)++import           Control.Concurrent.Async (Async)+import           Control.Concurrent.STM (TVar) import           Language.Fixpoint.Types-import           Language.Fixpoint.Types.Config (ElabFlags, Config)+import           Language.Fixpoint.Utils.Builder (Builder) import qualified Data.Text                as T import           Text.PrettyPrint.HughesPJ-import qualified SMTLIB.Backends  import           System.IO                (Handle)+import           System.Process -- import           Language.Fixpoint.Misc   (traceShow)  --------------------------------------------------------------------------------@@ -67,7 +59,6 @@                   | Distinct [Expr] -- {v:[Expr] | 2 <= len v}                   | GetValue [Symbol]                   | CMany    [Command]-                  | Comment T.Text                   deriving (Eq, Show)  instance PPrint Command where@@ -82,15 +73,14 @@ ppCmd (DeclData d)     = text "Data" <+> pprint d ppCmd (Declare x [] t) = text "Declare" <+> text (T.unpack x) <+> text ":" <+> pprint t ppCmd (Declare x ts t) = text "Declare" <+> text (T.unpack x) <+> text ":" <+> parens (pprint ts) <+> pprint t-ppCmd Define {}   = text "Define ..."-ppCmd (DefineFunc name symList rsort e) =-  text "DefineFunc" <+> pprint name <+> pprint symList <+> pprint rsort <+> pprint e+ppCmd (Define {})   = text "Define ..."+ppCmd (DefineFunc name params rsort e) =+  text "DefineFunc" <+> pprint name <+> pprint params <+> pprint rsort <+> pprint e ppCmd (Assert _ e)  = text "Assert" <+> pprint e ppCmd (AssertAx _)  = text "AssertAxiom ..."-ppCmd Distinct {} = text "Distinct ..."-ppCmd GetValue {} = text "GetValue ..."-ppCmd CMany {}    = text "CMany ..."-ppCmd (Comment t) = text ("; " ++ T.unpack t)+ppCmd (Distinct {}) = text "Distinct ..."+ppCmd (GetValue {}) = text "GetValue ..."+ppCmd (CMany {})    = text "CMany ..."  -- | Responses received from SMT engine data Response     = Ok@@ -101,55 +91,26 @@                   | Error !T.Text                   deriving (Eq, Show) --- | Additional information around the SMT solver backend+-- | Information about the external SMT process data Context = Ctx-  {-  -- | The high-level interface for interacting with the SMT solver backend.-    ctxSolver  :: SMTLIB.Backends.Solver-  , ctxElabF   :: ElabFlags-  -- | The close operation of the SMT solver backend.-  , ctxClose   :: IO ()+  { ctxPid     :: !ProcessHandle+  , ctxCin     :: !Handle+  , ctxCout    :: !Handle   , ctxLog     :: !(Maybe Handle)   , ctxVerbose :: !Bool   , ctxSymEnv  :: !SymEnv-  -- | The stack of sort indexes which were fresh at the corresponding level of push/pop stack.-  , ctxIxs     :: ![Int]-  , ctxDefines :: DefinedFuns-  -- | Flag which controls the generation SMT placeholders for lambda arguments-  --   See also `L.F.Smt.Theories.maxLamArg`-  , ctxLams    :: !Bool-  -- | Configuration options-  , config     :: !Config+    -- | 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   } --- | SMT monad, used to communicate with the SMT solver backend.---   The `SymM` monad embeds into it, as the symbolic state has to be threaded---   through for gnerating `apply`s and other function sort symbols.-type SmtM = StateT Context IO--liftSym :: SymM a -> SmtM a-liftSym s =-  do ctx <- get-     let (a, env') = runState s (ctxSymEnv ctx)-     put (ctx {ctxSymEnv = env'})-     pure a--catchSMT :: Exception e => SmtM a -> (e -> IO a) -> SmtM a-catchSMT action handler = StateT $ \s -> catch (runStateT action s) (fmap (, s) . handler)--bracketSMT :: SmtM a -> (a -> IO b) -> (a -> SmtM c) -> SmtM c-bracketSMT acquire release use = StateT $ \s ->-  bracket-    (runStateT acquire s)-    (\(resource, _) -> release resource)-    (\(resource, intermediateState) -> runStateT (use resource) intermediateState)- -------------------------------------------------------------------------------- -- | AST Conversion: Types that can be serialized ------------------------------ --------------------------------------------------------------------------------  class SMTLIB2 a where-  smt2 :: a -> SymM Builder+  smt2 :: SymEnv -> a -> Builder -runSmt2 :: (SMTLIB2 a) => a -> SymM Builder+runSmt2 :: (SMTLIB2 a) => SymEnv -> a -> Builder runSmt2 = smt2
src/Language/Fixpoint/Solver.hs view
@@ -3,12 +3,14 @@ --   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-    solve+    solve, Solver      -- * Invoke Solver on a .fq file   , solveFQ@@ -26,28 +28,25 @@  import           Control.Concurrent                 (setNumCapabilities) import qualified Data.HashMap.Strict              as HashMap-import qualified Data.HashSet                     as HashSet 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           Language.Fixpoint.Verbosity   (whenNormal, whenLoud)+import           System.Console.CmdArgs.Verbosity   (whenNormal, whenLoud)+import           Text.PrettyPrint.HughesPJ          (render) import           Control.Monad                      (when)-import           Control.Exception                  (SomeException, catch)-import           Control.Exception.Compat-    (ExceptionWithContext(..), displayExceptionContext, wrapExceptionWithContext)+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            (ElabParam (..), Elaborate (..), unElab, unElabFSetBagZ3)+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 qualified Language.Fixpoint.Solver.Solution  as Sol import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.Errors import           Language.Fixpoint.Utils.Files            hiding (Result)@@ -55,14 +54,11 @@ import           Language.Fixpoint.Utils.Statistics (statistics) import           Language.Fixpoint.Graph import           Language.Fixpoint.Parse            (rr')-import           Language.Fixpoint.Types hiding (GInfo(..), fi)-import qualified Language.Fixpoint.Types as Types (GInfo(..))+import           Language.Fixpoint.Types import           Language.Fixpoint.Minimize (minQuery, minQuals, minKvars)+import           Language.Fixpoint.Solver.Instantiate (instantiate) import           Control.DeepSeq-import           Data.Functor                        (void) import qualified Data.ByteString as B-import Data.Maybe (catMaybes)-import qualified Text.PrettyPrint.HughesPJ as PJ  --------------------------------------------------------------------------- -- | Solve an .fq file ----------------------------------------------------@@ -78,31 +74,29 @@     file    = srcFile      cfg  ----------------------------------------------------------------------------resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a+resultExitCode :: (Fixpoint a, NFData a, ToJSON a) => Config -> Result a                 -> IO ExitCode ----------------------------------------------------------------------------resultExitCode cfg r = do+resultExitCode cfg r = do    whenNormal $ colorStrLn (colorResult stat) (statStr $!! stat)   when (json cfg) $ LT.putStrLn jStr   return (eCode r)-  where+  where      jStr    = LT.decodeUtf8 . encode $ r     stat    = resStatus $!! r     eCode   = resultExit . resStatus-    statStr = PJ.render . resultDoc+    statStr = render . resultDoc   ignoreQualifiers :: Config -> FInfo a -> FInfo a ignoreQualifiers cfg fi-  | eliminate cfg == All = fi { Types.quals = [] }+  | eliminate cfg == All = fi { quals = [] }   | otherwise            = fi   -------------------------------------------------------------------------------- -- | Solve FInfo system of horn-clause constraints ----------------------------- ---------------------------------------------------------------------------------solve-  :: (PPrint a, NFData a, Fixpoint a, Show a, Loc a)-  => Config -> FInfo a -> IO (Result (Integer, a))+solve :: (NFData a, Fixpoint a, Show a, Loc a) => Solver a -------------------------------------------------------------------------------- solve cfg q   | parts cfg      = partition  cfg        $!! q@@ -112,19 +106,16 @@   | minimizeKs cfg = minKvars cfg solve'   $!! q   | otherwise      = solve'     cfg        $!! q --solve'-  :: (PPrint a, NFData a, Fixpoint a, Show a, Loc a)-  => Config -> FInfo a -> IO (Result (Integer, a))+solve' :: (NFData a, Fixpoint a, Show a, Loc a) => Solver a solve' cfg q = do-    when (save cfg) $ saveQuery cfg q-    res <- if multicore cfg then-             solvePar cfg q-           else-             solveNative cfg (slice cfg q)-    when (saveBfqOnError cfg && isUnsafe res) $ saveBinaryQuery cfg (void q)-    return res+  when (save cfg) $ saveQuery   cfg q+  configSW  cfg     solveNative cfg q +configSW :: (NFData a, Fixpoint a, Show a, Loc a) => Config -> Solver a -> Solver a+configSW cfg+  | multicore cfg = solveParWith+  | otherwise     = solveSeqWith+ -------------------------------------------------------------------------------- readFInfo :: FilePath -> IO (FInfo (), [String]) --------------------------------------------------------------------------------@@ -135,24 +126,30 @@ readFq :: FilePath -> IO (FInfo (), [String]) readFq file = do   str   <- readFile file-  let q  = {- SCC "parsefq" -} rr' file str :: FInfoWithOpts ()+  let q  = {- SCC "parsefq" #-} rr' file str :: FInfoWithOpts ()   return (fioFI q, fioOpts q)  readBinFq :: FilePath -> IO (FInfo ())-readBinFq file = {-# SCC "parseBFq" #-} do+readBinFq file = {-# SCC "parseBFq" #-} do    bs <- B.readFile file-  case S.decode bs of+  case S.decode bs of      Right fi -> return fi-    Left err' -> error ("Error decoding .bfq: " ++ show err')+    Left err -> error ("Error decoding .bfq: " ++ show err)   -------------------------------------------------------------------------------- -- | Solve in parallel after partitioning an FInfo to indepdendant parts ---------------------------------------------------------------------------------solvePar-  :: (Loc a, NFData a, PPrint a, Show a, Fixpoint a)-  => Config -> FInfo a -> IO (Result (Integer, a))+solveSeqWith :: (Fixpoint a) => Solver a -> Solver a+solveSeqWith s c fi0 = {- withProgressFI fi $ -} s c fi+  where+    fi               = slice c fi0+ ---------------------------------------------------------------------------------solvePar c fi0 = do+-- | Solve in parallel after partitioning an FInfo to indepdendant parts+--------------------------------------------------------------------------------+solveParWith :: (Fixpoint a) => Solver a -> Solver a+--------------------------------------------------------------------------------+solveParWith s c fi0 = do   -- putStrLn "Using Parallel Solver \n"   let fi    = slice c fi0   mci      <- mcInfo c@@ -163,10 +160,10 @@   writeLoud $ "maximum part size    : " ++ show (maxPartSize c)   case fis of     []        -> errorstar "partiton' returned empty list!"-    [onePart] -> solveNative c onePart-    _         -> inParallelUsing (f c) $ zip [1..] fis+    [onePart] -> s c onePart+    _         -> inParallelUsing (f s c) $ zip [1..] fis     where-      f c' (j, fi) = solveNative (c {srcFile = queryFile (Part j) c'}) fi+      f s c (j, fi) = s (c {srcFile = queryFile (Part j) c}) fi  -------------------------------------------------------------------------------- -- | Solve a list of FInfos using the provided solver function in parallel@@ -182,61 +179,25 @@ -------------------------------------------------------------------------------- -- | Native Haskell Solver ----------------------------------------------------- ---------------------------------------------------------------------------------solveNative, solveNative'-  :: (NFData a, Fixpoint a, Show a, Loc a, PPrint a)-  => Config -> FInfo a -> IO (Result (Integer, a))+solveNative, solveNative' :: (NFData a, Fixpoint a, Show a, Loc a) => Solver a ---------------------------------------------------------------------------------solveNative !cfg !fi0 = solveNative' cfg fi0-                          `catch`-                             (return . crashResult (errorMap fi0) . wrapExceptionWithContext)+solveNative !cfg !fi0 = (solveNative' cfg fi0)                           `catch`-                             (return . crashResultOther . wrapExceptionWithContext)--crashResult :: (PPrint a) => ErrorMap a -> ExceptionWithContext Error -> Result (Integer, a)-crashResult m (ExceptionWithContext ectx ex) = Result res mempty mempty mempty-  where-    res = Crash es msg-    es  = catMaybes [ findError m e | e <- ers ]-    ers = errs ex-    msg = displayExceptionContext ectx ++ "\n" ++ msg0-    msg0 | null ers = "Sorry, unexpected panic in liquid-fixpoint!\n"-                       ++ showpp ex-         | otherwise = showpp ex--crashResultOther-  :: ExceptionWithContext SomeException -> Result (Integer, a)-crashResultOther (ExceptionWithContext ectx ex) =-    Result res mempty mempty mempty-  where-    res = Crash [] msg-    msg = displayExceptionContext ectx ++ "\n" ++ msg0-    msg0 = "Sorry, unexpected panic in liquid-fixpoint!\n" ++ show ex---- | Unpleasant hack to save meta-data that can be recovered from SrcSpan-type ErrorMap a = HashMap.HashMap SrcSpan a--findError :: ErrorMap a -> Error1 -> Maybe ((Integer, a), Maybe String)-findError m e = do-  ann <- HashMap.lookup (errLoc e) m-  let str = PJ.render (errMsg e)-  return ((-1, ann), Just str)+                             (return . result) --- The order is important here: we want the "binders" to get the "precedence"-errorMap :: (Loc a) => FInfo a -> ErrorMap a-errorMap fi = HashMap.fromList [ (srcSpan a, a) | a <- anns ]+result :: Error -> Result a+result e = Result (Crash [] msg) mempty mempty mempty   where-    anns    =  [ sinfo c | (_, c) <- HashMap.toList (Types.cm fi) ]-            ++ [ winfo w | (_, w) <- HashMap.toList (Types.ws fi) ]-            ++ [ a | (_, (_,_, a)) <- bindEnvToList (Types.bs fi) ]+    msg  = showpp e  loudDump :: (Fixpoint a) => Int -> Config -> SInfo a -> IO ()-loudDump i cfg si = when False (writeLoud $ msg ++ PJ.render (toFixpoint cfg si))+loudDump i cfg si = when False (writeLoud $ msg ++ render (toFixpoint cfg si))   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 (ElabParam, SInfo a)+               => Config -> FInfo a -> IO (SInfo a) simplifyFInfo !cfg !fi0 = do   -- writeLoud $ "fq file in: \n" ++ render (toFixpoint cfg fi)   -- rnf fi0 `seq` donePhase Loud "Read Constraints"@@ -244,53 +205,46 @@   -- whenLoud $ print qs   -- whenLoud $ putStrLn $ showFix (quals fi1)   reducedFi <- reduceFInfo cfg fi0-  let fi1   = reducedFi { Types.quals = remakeQual <$> Types.quals reducedFi }-  let si0   = {- SCC "convertFormat" -} convertFormat fi1+  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-  -- writeLoud $ "fq file after wfcUniqify: \n" ++ render (toFixpoint cfg si2)-  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-  -- writeLoud $ "fq file after defunc: \n" ++ render (toFixpoint cfg si4)+  let si4  = {- SCC "defunction" #-} defunctionalize cfg $!! si3   -- putStrLn $ "AXIOMS: " ++ showpp (asserts si4)   loudDump 2 cfg si4-  let ef = solverFlags cfg-      elabParam = ElabParam-                     ef-                     (atLoc dummySpan "solver")-                     (coerceEnv ef (symbolEnv cfg si4))-      si5  = elaborate elabParam si4-  -- writeLoud $ "fq file after elaborate: \n" ++ render (toFixpoint cfg si5)+  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-  return (elabParam, si6){- SCC "elaborate" -}+  let si6 = if extensionality cfg then {- SCC "expand"     #-} expand cfg si5 else si5+  if rewriteAxioms cfg && noLazyPLE cfg+    then instantiate cfg si6 $!! Nothing+    else return si6  reduceFInfo :: Fixpoint a => Config -> FInfo a -> IO (FInfo a) reduceFInfo cfg fi = do-  let simplifiedFi = {- SCC "simplifyFInfo" -} simplifyBindings cfg fi-      reducedFi = {- SCC "reduceEnvironments" -} reduceEnvironments simplifiedFi+  let simplifiedFi = {- SCC "simplifyFInfo" #-} simplifyBindings cfg fi+      reducedFi = {- SCC "reduceEnvironments" #-} reduceEnvironments simplifiedFi   when (save cfg) $     savePrettifiedQuery cfg reducedFi-  if noEnvReduction cfg then+  if noEnvironmentReduction cfg then     return fi   else     return reducedFi  solveNative' !cfg !fi0 = do-  (elabParam, si6) <- simplifyFInfo cfg fi0-  res0 <- {- SCC "Sol.solve" -} Sol.solve cfg elabParam $!! si6-  let res = simplifyResult cfg res0+  si6 <- simplifyFInfo cfg fi0+  res <- {- SCC "Sol.solve" #-} Sol.solve cfg $!! si6   -- rnf soln `seq` donePhase Loud "Solve2"   --let stat = resStatus res   -- saveSolution cfg res-  when (save cfg) $ Sol.saveSolution cfg "" res+  when (save cfg) $ saveSolution cfg res   -- writeLoud $ "\nSolution:\n"  ++ showpp (resSolution res)   -- colorStrLn (colorResult stat) (show stat)   return res@@ -306,18 +260,26 @@ parseFI f = do   str   <- readFile f   let fi = rr' f str :: FInfo ()-  return $ mempty { Types.quals = Types.quals  fi-                  , Types.gLits = Types.gLits  fi-                  , Types.dLits = Types.dLits  fi }+  return $ mempty { quals = quals  fi+                  , gLits = gLits  fi+                  , dLits = dLits  fi } -simplifyResult :: Config -> Result a -> Result a-simplifyResult cfg res =-    res-      { resSolution = HashMap.map simplifyKVar' (resSolution res)-      , resNonCutsSolution = HashMap.map (fmap simplifyKVar') (resNonCutsSolution res)-      }-  where-    simplifyKVar' = unElabSets . unElab' . Sol.simplifyKVar HashSet.empty-    sets          = elabSetBag . solverFlags $ cfg-    unElabSets    = if sets then unElabFSetBagZ3 else id-    unElab'       = if sortedSolution cfg then id else unElab+saveSolution :: Config -> Result a -> IO ()+saveSolution cfg res = when (save cfg) $ do+  let f = queryFile Out cfg+  putStrLn $ "Saving Solution: " ++ f ++ "\n"+  ensurePath f+  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/Common.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Language.Fixpoint.Solver.Common (askSMT, toSMT) where--import Control.Monad.State-import Language.Fixpoint.Types.Config (Config, solverFlags)-import Language.Fixpoint.Smt.Interface (Context(..), checkValidWithContext)-import Language.Fixpoint.Smt.Types (SmtM)-import Language.Fixpoint.Types-import Language.Fixpoint.Types.Visitor (kvarsExpr)-import Language.Fixpoint.Defunctionalize (defuncAny)-import Language.Fixpoint.SortCheck (ElabParam(..), elaborate)-import GHC.Stack (HasCallStack)--mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp--askSMT-  :: HasCallStack-  => Config-  -> [(Symbol, Sort)] -- ^ symbols already declared in the SMT solver-  -> [(Symbol, Sort)] -- ^ symbols to declare in the SMT solver-  -> Expr-  -> SmtM Bool-askSMT cfg bsInSMT xs e-  | isTautoPred  e     = return True-  | null (kvarsExpr e) =-      do ctx <- get-         let e' = toSMT "askSMT" cfg ctx (xs ++ bsInSMT) e-         checkValidWithContext xs PTrue e'-  | otherwise          = return False--toSMT :: HasCallStack => String -> Config -> Context -> [(Symbol, Sort)] -> Expr -> Pred-toSMT msg cfg ctx xs e =-    defuncAny cfg symenv .-        elaborate (ElabParam (solverFlags cfg) (dummyLoc msg) (elabEnv xs)) .-            mytracepp ("toSMT from " ++ msg ++ " > " ++ showpp e) $-                e-  where-    elabEnv = insertsSymEnv symenv-    symenv  = ctxSymEnv ctx
src/Language/Fixpoint/Solver/Eliminate.hs view
@@ -16,61 +16,38 @@ import           Language.Fixpoint.Types.Visitor   (kvarsExpr, isConcC) import           Language.Fixpoint.Graph import           Language.Fixpoint.Misc            (safeLookup, group, errorstar)+import           Language.Fixpoint.Solver.Sanitize  -------------------------------------------------------------------------------- -- | `solverInfo` constructs a `SolverInfo` comprising the Solution and various --   indices needed by the worklist-based refinement loop------ Computes the set of cut and non-cut kvars, computes the hypotheses common--- to all of the usage sites of each kvar, then initializes the solutions of--- the non-cut KVars (in the sHyp field).------ This is part of the implementation of the FUSION algorithm described in:------ "Local Refinement Typing", ICFP 2017, https://ranjitjhala.github.io/static/local_refinement_typing.pdf--- -------------------------------------------------------------------------------- {-# SCC solverInfo #-}-solverInfo :: Config -> SInfo a -> SolverInfo a+solverInfo :: Config -> SInfo a -> SolverInfo a b -------------------------------------------------------------------------------- solverInfo cfg sI = SI sHyp sI' cD cKs   where-    cD             = elimDeps     sI es nKs+    cD             = elimDeps     sI es nKs ebs     sI'            = cutSInfo     sI kI cKs-    sHyp = Sol.Sol-      { Sol.sMap = mempty-      , Sol.sHyp = M.fromList kHyps-      , Sol.sScp = kS-      }+    sHyp           = Sol.fromList sE mempty mempty kHyps kS [] $ fromListSEnv [ (x, (i, sr_sort sr)) | (i,x,sr) <- bindEnvToList (bs sI)]     kHyps          = nonCutHyps   sI kI nKs     kI             = kIndex       sI     (es, cKs, nKs) = kutVars cfg  sI     kS             = kvScopes     sI es+    sE             = symbolEnv   cfg sI+    ebs            = S.fromList $ fst <$> flip lookupBindEnv (bs sI) <$> (ebinds sI) + ----------------------------------------------------------------------------------- | For each KVar, provide the intersection of the binding environments---   of all the constraints in which it appears.------ See Section 2.4 of "Local Refinement Typing", ICFP 2017, for the motivation--- to collect these. kvScopes :: SInfo a -> [CEdge] -> M.HashMap KVar IBindEnv-kvScopes sI es = commonBindingsOfConstraints <$> kvarUses+kvScopes sI es = is2env <$> kiM   where-    -- | The common bindings of a list of constraints-    commonBindingsOfConstraints :: [Integer] -> IBindEnv-    commonBindingsOfConstraints =-      foldr1 intersectionIBindEnv . fmap (senv . getSubC sI)--    -- | The constraints in which each KVar appears-    kvarUses :: M.HashMap KVar [Integer]-    kvarUses =-      group $ [(k, i) | (Cstr i, KVar k) <- es ] ++-              [(k, i) | (KVar k, Cstr i) <- es ]+    is2env = foldr1 intersectionIBindEnv . fmap (senv . getSubC sI)+    kiM    = group $ [(k, i) | (Cstr i, KVar k) <- es ] +++                     [(k, i) | (KVar k, Cstr i) <- es ]  ----------------------------------------------------------------------------------- | @cutSInfo si kI cKs@ drops well-formed constraints that don't refer to the--- KVars in @cKs@. Also drops subtyping constraints that don't refer in their--- RHS to any of the KVars in @cKs@ or which aren't concrete.+ cutSInfo :: SInfo a -> KIndex -> S.HashSet KVar -> SInfo a cutSInfo si kI cKs = si { ws = ws', cm = cm' }   where@@ -79,17 +56,13 @@     cs    = S.fromList      (concatMap kCs cKs)     kCs k = M.lookupDefault [] k kI --- | Compute Dependencies and Cuts------ Yields the edges of the dependency graph, then the set of KVars whose removal--- makes the graph acyclic (cuts), and finally the rest of the KVars. kutVars :: Config -> SInfo a -> ([CEdge], S.HashSet KVar, S.HashSet KVar) kutVars cfg si   = (es, depCuts ds, depNonCuts ds)   where     (es, ds)     = elimVars cfg si  ----------------------------------------------------------------------------------- | Map each 'KVar' to the list of constraints on which it appears on RHS+-- | Map each `KVar` to the list of constraints on which it appears on RHS -------------------------------------------------------------------------------- type KIndex = M.HashMap KVar [Integer] @@ -111,12 +84,12 @@     cs            = getSubC   si <$> M.lookupDefault [] k kI  nonCutCube :: SimpC a -> Sol.Cube-nonCutCube c = Sol.Cube (senv c) (substFromKSubst $ rhsSubst c) (subcId c) (stag c)+nonCutCube c = Sol.Cube (senv c) (rhsSubst c) (subcId c) (stag c) -rhsSubst :: SimpC a -> KVarSubst Symbol Symbol+rhsSubst :: SimpC a -> Subst rhsSubst             = rsu . crhs   where-    rsu (PKVar _ _ su) = su+    rsu (PKVar _ su) = su     rsu _            = errorstar "Eliminate.rhsSubst called on bad input"  getSubC :: SInfo a -> Integer -> SimpC a
src/Language/Fixpoint/Solver/EnvironmentReduction.hs view
@@ -1,27 +1,19 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}  -- | Functions to make environments smaller module Language.Fixpoint.Solver.EnvironmentReduction   ( reduceEnvironments   , simplifyBindings   , dropLikelyIrrelevantBindings-  , relatedSymbols-  , inlineInExpr   , inlineInSortedReft   , mergeDuplicatedBindings   , simplifyBooleanRefts   , undoANF-  , undoANFAndVV--  -- for use in tests-  , undoANFSimplifyingWith   ) where  import           Control.Monad (guard, mplus, msum)@@ -32,18 +24,12 @@ import qualified Data.HashMap.Strict as HashMap.Strict import           Data.HashSet (HashSet) import qualified Data.HashSet as HashSet-#if MIN_VERSION_base(4,20,0)-import           Data.List (partition)-#else-import           Data.List (foldl', partition)-#endif-import           Data.Functor.Const (Const(..))-import           Data.Functor.Identity (Identity(..))+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 (exprSortMaybe)+import           Language.Fixpoint.SortCheck (exprSort_maybe) import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.Constraints import           Language.Fixpoint.Types.Environments@@ -69,19 +55,16 @@   , isPrefixOfSym   , prefixOfSym   , symbolText-  , vvName   ) import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Refinements   ( Brel(..)-  , ExprBV(..)-  , Expr+  , Expr(..)   , KVar(..)   , SortedReft(..)-  , KVarSubst+  , Subst(..)   , pattern PTrue   , pattern PFalse-  , dropECst   , expr   , exprKVars   , exprSymbolsSet@@ -92,11 +75,9 @@   , reftPred   , sortedReftSymbols   , subst1-  , fromKVarSubst   ) import           Language.Fixpoint.Types.Sorts (boolSort, sortSymbols) import           Language.Fixpoint.Types.Visitor (mapExprOnExpr)-import Language.Fixpoint.Misc (snd3)  -- | Strips from all the constraint environments the bindings that are -- irrelevant for their respective constraints.@@ -142,33 +123,37 @@ -- See #473 for more discussion. -- reduceEnvironments :: FInfo a -> FInfo a-reduceEnvironments finfo =-  let constraints = HashMap.Strict.toList $ cm finfo-      aenvMap = axiomEnvSymbols (ae finfo)-      reducedEnvs = map (reduceConstraintEnvironment (bs finfo) aenvMap) constraints-      (cm', ws') = reduceWFConstraintEnvironments (bs finfo) (reducedEnvs, ws finfo)-      bs' = (bs finfo) { beBinds = dropBindsMissingFrom (beBinds $ bs finfo) cm' ws' }+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 finfo+   in fi      { bs = bs'      , cm = HashMap.fromList cm'      , ws = ws'-     , bindInfo = updateBindInfoKeys bs' $ bindInfo finfo+     , ebinds = updateEbinds bs' (ebinds fi)+     , bindInfo = updateBindInfoKeys bs' $ bindInfo fi      }    where     dropBindsMissingFrom-      :: HashMap BindId (Symbol, SortedReft, a)+      :: HashMap BindId (Symbol, SortedReft)       -> [(SubcId, SubC a)]       -> HashMap KVar (WfC a)-      -> HashMap BindId (Symbol, SortedReft, a)-    dropBindsMissingFrom be cs wmap =+      -> HashMap BindId (Symbol, SortedReft)+    dropBindsMissingFrom be cs ws =       let ibindEnv = unionsIBindEnv $             map (senv . snd) cs ++-            map wenv (HashMap.elems wmap)+            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)@@ -183,7 +168,7 @@ -- 'relatedKVarBinds' or any substitution on the corresponding KVar anywhere. -- reduceWFConstraintEnvironments-  :: BindEnv a    -- ^ Environment before reduction+  :: BindEnv    -- ^ Environment before reduction   -> ([ReducedConstraint a], HashMap KVar (WfC a))      -- ^ @(cs, ws)@:      --  * @cs@ are the constraints with reduced environments@@ -198,11 +183,12 @@         HashMap.map (sortSymbols . (\(_, b, _) -> b) . wrft) wfs        kvarsRelevantBinds =-        HashMap.unionWith HashSet.union wfBindsPlusSortSymbols kvarSubstSymbols+        HashMap.unionWith HashSet.union wfBindsPlusSortSymbols $+        kvarSubstSymbols        ws' =         HashMap.mapWithKey-          (reduceWFConstraintEnvironment kvarsRelevantBinds)+          (reduceWFConstraintEnvironment bindEnv kvarsRelevantBinds)           wfs        wsSymbols = HashMap.map (asSymbolSet bindEnv . wenv) ws'@@ -211,7 +197,7 @@         HashMap.unionWith HashSet.intersection wfBindsPlusSortSymbols wsSymbols        cs' = zipWith-              (updateSubcEnvsWithKVarBinds kvarsWsBinds)+              (updateSubcEnvsWithKVarBinds bindEnv kvarsWsBinds)               kvarsBySubC               cs    in@@ -223,22 +209,23 @@     -- additional bindings that are required by the kvar. These are added     -- in this function.     updateSubcEnvsWithKVarBinds-      :: HashMap KVar (HashSet Symbol)+      :: BindEnv+      -> HashMap KVar (HashSet Symbol)       -> [KVar]       -> ReducedConstraint a       -> (SubcId, SubC a)-    updateSubcEnvsWithKVarBinds kvarsBinds kvs c =+    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 bindEnv+              , let (s, _sr) = lookupBindEnv bId be               , any (neededByKVar s) kvs               ]-          neededByKVar s kvar =-            case HashMap.lookup kvar kvarsBinds of+          neededByKVar s kv =+            case HashMap.lookup kv kvarsBinds of               Nothing -> False               Just kbindSyms -> HashSet.member s kbindSyms        in (constraintId c, updateSEnv (originalConstraint c) updateIBindEnv)@@ -246,11 +233,12 @@     -- @reduceWFConstraintEnvironment be kbinds k c@ drops bindings from @c@     -- that aren't present in @kbinds ! k@.     reduceWFConstraintEnvironment-      :: HashMap KVar (HashSet Symbol)+      :: BindEnv+      -> HashMap KVar (HashSet Symbol)       -> KVar       -> WfC a       -> WfC a-    reduceWFConstraintEnvironment kvarBinds k c =+    reduceWFConstraintEnvironment bindEnv kvarBinds k c =       case HashMap.lookup k kvarBinds of         Nothing -> c { wenv = emptyIBindEnv }         Just kbindSymbols ->@@ -258,7 +246,7 @@       where         relevantBindIds :: HashSet Symbol -> BindId -> Bool         relevantBindIds kbindSymbols bId =-          let (s, _, _) = lookupBindEnv bId bindEnv+          let (s, _) = lookupBindEnv bId bindEnv            in HashSet.member s kbindSymbols  data ReducedConstraint a = ReducedConstraint@@ -268,18 +256,18 @@   }  reduceConstraintEnvironment-  :: BindEnv a+  :: BindEnv   -> HashMap Symbol (HashSet Symbol)   -> (SubcId, SubC a)   -> ReducedConstraint a reduceConstraintEnvironment bindEnv aenvMap (cid, c) =-  let env = [ (s, bId, sr, a)+  let env = [ (s, bId, sr)             | bId <- elemsIBindEnv $ senv c-            , let (s, sr, a) = lookupBindEnv bId bindEnv+            , let (s, sr) = lookupBindEnv bId bindEnv             ]       prunedEnv =         fromListIBindEnv-        [ bId | (_, bId, _,_) <- dropIrrelevantBindings aenvMap constraintSymbols env ]+        [ bId | (_, bId, _) <- dropIrrelevantBindings aenvMap constraintSymbols env ]       constraintSymbols =         HashSet.union (sortedReftSymbols $ slhs c) (sortedReftSymbols $ srhs c)    in ReducedConstraint@@ -300,24 +288,17 @@ dropIrrelevantBindings   :: HashMap Symbol (HashSet Symbol)   -> HashSet Symbol-  -> [(Symbol, BindId, SortedReft, a)]-  -> [(Symbol, BindId, SortedReft, a)]+  -> [(Symbol, BindId, SortedReft)]+  -> [(Symbol, BindId, SortedReft)] dropIrrelevantBindings aenvMap extraSymbols env =   filter relevantBind env   where     allSymbols =-      reachableSymbols (HashSet.unions [extraSymbols, envSymbols, withKVars]) aenvMap+      reachableSymbols (HashSet.union extraSymbols envSymbols) aenvMap     envSymbols =-      HashSet.unions $ map (\(_, _, sr,_) -> sortedReftSymbols sr) env--    -- If there are bindings with KVars, we include them to be conservative.-    withKVars =-      HashSet.fromList $-      map fst $-      filter (not . HashMap.null . exprKVars . reftPred . sr_reft . snd) $-      map (\(x, _, sr, _) -> (x, sr)) env+      HashSet.unions $ map (\(_, _, sr) -> sortedReftSymbols sr) env -    relevantBind (s, _, sr, _)+    relevantBind (s, _, sr)       | HashSet.member s allSymbols = True       | otherwise = case reftPred (sr_reft sr) of           PTrue -> False@@ -327,10 +308,10 @@  -- | For each Equation and Rewrite, collects the symbols that it needs. axiomEnvSymbols :: AxiomEnv -> HashMap Symbol (HashSet Symbol)-axiomEnvSymbols axiomEnv =+axiomEnvSymbols ae =   HashMap.union-    (HashMap.fromList $ map eqSymbols $ aenvEqs axiomEnv)-    (HashMap.fromList $ map rewriteSymbols $ aenvSimpl axiomEnv)+    (HashMap.fromList $ map eqSymbols $ aenvEqs ae)+    (HashMap.fromList $ map rewriteSymbols $ aenvSimpl ae)   where     eqSymbols eq =       let bodySymbols =@@ -384,7 +365,7 @@ -- be needed by the other. -- relatedKVarBinds-  :: BindEnv a+  :: BindEnv   -> [ReducedConstraint a]   -> (HashMap KVar (HashSet Symbol), HashMap KVar (HashSet Symbol), [[KVar]]) relatedKVarBinds bindEnv cs =@@ -399,17 +380,18 @@    in       (bindIdsByKVar, substsByKVar, kvarsBySubC)   where-    kvarsByBindId :: HashMap BindId (HashMap KVar [KVarSubst Symbol Symbol])+    kvarsByBindId :: HashMap BindId (HashMap KVar [Subst])     kvarsByBindId =-      HashMap.map (exprKVars . reftPred . sr_reft . snd3) $ beBinds bindEnv+      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 fromKVarSubst+            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) :) $@@ -436,12 +418,12 @@         let sm' = ShareMap.insertWith unionIBindEnv k bindIds sm          in foldr (ShareMap.mergeKeysWith unionIBindEnv k) sm' ks -asSymbolSet :: BindEnv a -> IBindEnv -> HashSet Symbol+asSymbolSet :: BindEnv -> IBindEnv -> HashSet Symbol asSymbolSet be ibinds =   HashSet.fromList     [ s     | bId <- elemsIBindEnv ibinds-    , let (s, _,_) = lookupBindEnv bId be+    , let (s, _) = lookupBindEnv bId be     ]  -- | @reachableSymbols x r@ computes the set of symbols reachable from @x@@@ -464,17 +446,23 @@ -- It runs 'mergeDuplicatedBindings' and 'simplifyBooleanRefts' -- on the environment of each constraint. ----- If 'inlineANFBindings cfg' is on, also runs 'undoANFAndVV' to inline+-- If 'inlineANFBindings cfg' is on, also runs 'undoANF' to inline -- @lq_anf@ bindings. simplifyBindings :: Config -> FInfo a -> FInfo a-simplifyBindings cfg finfo =-  let (bs', cm', oldToNew) = simplifyConstraints (bs finfo) (cm finfo)-   in finfo+simplifyBindings cfg fi =+  let (bs', cm', oldToNew) = simplifyConstraints (bs fi) (cm fi)+   in fi         { bs = bs'         , cm = cm'-        , bindInfo = updateBindInfoKeys oldToNew $ bindInfo finfo+        , 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 =@@ -486,39 +474,39 @@         ]      simplifyConstraints-      :: BindEnv a+      :: BindEnv       -> HashMap SubcId (SubC a)-      -> (BindEnv a, HashMap SubcId (SubC a), HashMap BindId [BindId])+      -> (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 (, [n]) olds) newToOld+            concatMap (\(n, olds) -> map (\o -> (o, [n])) olds) newToOld        in           (be', HashMap.fromList cs', oldToNew)      simplifyConstraintBindings-      :: (BindEnv a, [(SubcId, SubC a)], [(BindId, [BindId])])+      :: (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])])       -> SubcId       -> SubC a-      -> (BindEnv a, [(SubcId, SubC a)], [(BindId, [BindId])])+      -> (BindEnv, [(SubcId, SubC a)], [(BindId, [BindId])])     simplifyConstraintBindings (bindEnv, cs, newToOld) cid c =       let env =-            [ (s, ([(bId, a)], sr))+            [ (s, ([bId], sr))             | bId <- elemsIBindEnv $ senv c-            , let (s, sr, a) = lookupBindEnv bId bindEnv+            , let (s, sr) = lookupBindEnv bId bindEnv             ]            mergedEnv = mergeDuplicatedBindings env           undoANFEnv =-            if inlineANFBinds cfg then undoANFOnlyModified mergedEnv else HashMap.empty+            if inlineANFBindings cfg then undoANF mergedEnv else HashMap.empty           boolSimplEnv =             simplifyBooleanRefts $ HashMap.union undoANFEnv mergedEnv            modifiedBinds = HashMap.toList $ HashMap.union boolSimplEnv undoANFEnv -          modifiedBindIds = [ fst <$> bindIds | (_, (bindIds,_)) <- modifiedBinds ]+          modifiedBindIds = map (fst . snd) modifiedBinds            unchangedBindIds = senv c `diffIBindEnv` fromListIBindEnv (concat modifiedBindIds) @@ -530,9 +518,9 @@        in           (bindEnv', (cid, updateSEnv c (const newIBindEnv)) : cs, newToOld') -    insertBinds = foldl' $ \(xs, be) (s, (bIdAs, sr)) ->-      let (bId, be') = insertBindEnv s sr (snd . head $ bIdAs) be-      in (bId : xs, be')+    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.@@ -571,94 +559,45 @@           ]         ) --- lens------ We use internally the following lens to modify the SortedReft in the--- environment. This was imported from lens-family, but we don't want to depend--- on the whole library for just these few definitions.--type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s--_2 :: Lens' (a, b) b-_2 f (a, b) = fmap (a,) (f b)--view :: Lens' s a -> s -> a-view l s = getConst (l Const s)--infixr 4 %~--(%~) :: Lens' s a -> (a -> a) -> s -> s-(%~) l f s = runIdentity (l (Identity . f) s)---- | Inlines some of the bindings whose symbol satisfies a given predicate.------ Only works if the bindings don't form cycles.-substBindingsSimplifyingWith-  :: (SortedReft -> SortedReft)-  -> Lens' v SortedReft-  -> (Symbol -> Bool)-  -> HashMap Symbol v-  -> HashMap Symbol v-substBindingsSimplifyingWith simplifier vLens p env =-    -- Circular program here. This should terminate as long as the-    -- bindings introduced by ANF don't form cycles.-    let env' = HashMap.map (vLens %~ simplifier . inlineInSortedReft (srLookup filteredEnv)) env-        filteredEnv = HashMap.filterWithKey (\sym _v -> p sym) env'-     in env'-  where-    srLookup env' sym = view vLens <$> HashMap.lookup sym env'--substBindings-  :: Lens' v SortedReft-  -> (Symbol -> Bool)-  -> HashMap Symbol v-  -> HashMap Symbol v-substBindings = substBindingsSimplifyingWith simplify---- | Like 'substBindings' but specialized for ANF bindings.+-- | Inlines some of the bindings introduced by ANF normalization+-- at their use sites. ----- Only bindings with prefix lq_anf$... might be inlined.+-- Only modified bindings are returned. ---undoANFSimplifyingWith :: (SortedReft -> SortedReft) -> Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v-undoANFSimplifyingWith simplifier vLens = substBindingsSimplifyingWith simplifier vLens $ \sym -> anfPrefix `isPrefixOfSym` sym--undoANF :: Lens' v SortedReft -> HashMap Symbol v -> HashMap Symbol v-undoANF = undoANFSimplifyingWith simplify---- | Like 'undoANF' but also inlines VV bindings+-- 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.------ Note: This function simplifies.-undoANFAndVV :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)-undoANFAndVV = substBindings _2 $ \sym -> anfPrefix `isPrefixOfSym` sym || vvName `isPrefixOfSym` sym---- | Like 'undoANF' but returns only modified bindings and **DOES NOT SIMPLIFY**.-undoANFOnlyModified :: HashMap Symbol (m, SortedReft) -> HashMap Symbol (m, SortedReft)-undoANFOnlyModified env =-    let undoANFEnv = undoANFSimplifyingWith id _2 env-     in HashMap.differenceWith dropUnchanged env undoANFEnv+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 (_, a) v@(_, b) | a == b = Just v-      | otherwise = Nothing+    dropUnchanged ((m, b), sr) = do+      guard b+      Just (m, sr) --- | Inlines bindings in env in the given 'SortedReft'. inlineInSortedReft-  :: (Symbol -> Maybe SortedReft)-  -> SortedReft-  -> SortedReft-inlineInSortedReft srLookup sr =-    let reft' = sr_reft sr-     in sr { sr_reft = mapPredReft (inlineInExpr (filterBind (reftBind reft'))) reft' }-  where-    filterBind b sym = do-      guard (sym /= b)-      srLookup sym+  :: HashMap Symbol (m, SortedReft) -> SortedReft -> SortedReft+inlineInSortedReft env sr =+  snd $ inlineInSortedReftChanged env (error "never should evaluate", sr) --- | Inlines bindings given by @srLookup@ in the given expression+-- | 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 ...@,@@ -671,17 +610,23 @@ -- 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@.-inlineInExpr :: (Symbol -> Maybe SortedReft) -> Expr -> Expr-inlineInExpr srLookup = mapExprOnExpr inlineExpr+--+-- 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)-      | Just sr <- srLookup 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))-      | isEq br-      , Just sr <- srLookup sym+      | anfPrefix `isPrefixOfSym` sym+      , isEq br+      , Just (_, sr) <- HashMap.lookup sym env       , let r = sr_reft sr       , Just e <- isSingletonE (reftBind r) (reftPred r)       =@@ -703,10 +648,15 @@      isEq r = r == Eq || r == Ueq -    wrapWithCoercion br to e = case exprSortMaybe e of+    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}@.@@ -732,7 +682,7 @@     findExpr e es = do       case partition (e ==) es of         ([], _) -> Nothing-        (f:_, rest) -> Just (f, rest)+        (e:_, rest) -> Just (e, rest)  -- | @dropLikelyIrrelevantBindings ss env@ is like @dropIrrelevantBindings@ -- but drops bindings that could potentially be necessary to validate a@@ -763,14 +713,7 @@   -> HashMap Symbol SortedReft dropLikelyIrrelevantBindings ss env = HashMap.filterWithKey relevant env   where-    directlyUses = HashMap.map (exprSymbolsSet . reftPred . sr_reft) env-    relatedSyms = relatedSymbols (HashSet.union ss withKVars) directlyUses-    -- If there are bindings with KVars, we include them to be conservative.-    withKVars =-      HashSet.fromList $-      map fst $-      filter (not . HashMap.null . exprKVars . reftPred . sr_reft . snd) $-      HashMap.toList env+    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@@ -786,10 +729,10 @@ -- @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 (HashSet Symbol) -> HashSet Symbol-relatedSymbols ss0 directlyUses = go HashSet.empty ss0+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
src/Language/Fixpoint/Solver/Extensionality.hs view
@@ -1,284 +1,258 @@-{-# LANGUAGE CPP                  #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE PatternGuards        #-} {-# LANGUAGE FlexibleContexts     #-} -{-# LANGUAGE MultiParamTypeClasses #-}- module Language.Fixpoint.Solver.Extensionality (expand) where  import           Control.Monad.State import qualified Data.HashMap.Strict       as M import           Data.Maybe  (fromMaybe)-#if !MIN_VERSION_base(4,20,0)-import           Data.List (foldl')-#endif  import           Language.Fixpoint.Types.Config import           Language.Fixpoint.SortCheck import           Language.Fixpoint.Solver.Sanitize (symbolEnv) import           Language.Fixpoint.Types hiding (mapSort, Pos)-import           Language.Fixpoint.Types.Visitor (mapSort)+import           Language.Fixpoint.Types.Visitor ( (<$$>), mapSort )  mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp+mytracepp = notracepp   expand :: Config -> SInfo a -> SInfo a-expand cfg si = evalState (ext si) $ initST (symbolEnv cfg si) (ddecls si) (solverFlags cfg)-  where-    ext :: SInfo a -> Ex a (SInfo a)-    ext = extend+expand cfg si = evalState (extend si) $ initST (symbolEnv cfg si) (ddecls si)  -class Extend ann a where-  extend :: a -> Ex ann a+class Extend a where+  extend :: a -> Ex a  -instance Extend a (SInfo a) where-  extend si = do+instance Extend (SInfo a) where+  extend si = do      setBEnv (bs si)-    cm'      <- extend (cm si)-    bs'      <- gets exbenv+    cm'      <- extend (cm si) +    bs'      <- exbenv <$> get       return $ si{ cm = cm' , bs = bs' } -instance (Extend ann a) => Extend ann (M.HashMap SubcId a) where-  extend h  = M.fromList <$> mapM extend (M.toList h)+instance (Extend a) => Extend (M.HashMap SubcId a) where +  extend h = M.fromList <$> mapM extend (M.toList h)  -instance (Extend ann a, Extend ann b) => Extend ann (a,b) where-  extend (a,b) = (,) <$> extend a <*> extend b+instance (Extend a, Extend b) => Extend (a,b) where +  extend (a,b) = (,) <$> extend a <*> extend b  -instance Extend ann SubcId where-  extend i = return i+instance Extend SubcId where+  extend i = return i  -instance Extend a (SimpC a) where-  extend c = do+instance Extend (SimpC a) where+  extend c = do      setExBinds (_cenv c)-    rhs <- extendExpr (sinfo c) Pos (_crhs c)-    is  <- gets exbinds+    rhs <- extendExpr Pos (_crhs c)+    is  <- exbinds <$> get      return $ c{_crhs = rhs, _cenv = is }  -extendExpr :: a -> Pos -> Expr -> Ex a Expr-extendExpr ann p expr'-  | p == Pos-  = mapMPosExpr Pos goP e' >>= mapMPosExpr Pos goN+extendExpr :: Pos -> Expr -> Ex Expr +extendExpr p e +  | p == Pos +  = mapMPosExpr Pos goP e' >>= mapMPosExpr Pos goN    | otherwise-  = mapMPosExpr Neg goP e' >>= mapMPosExpr Neg goN-    where-      e' = normalize expr'+  = mapMPosExpr Neg goP e' >>= mapMPosExpr Neg goN +    where  +      e' = normalize e       goP Pos (PAtom b e1 e2)-       | b == Eq || b == Ne+       | b == Eq || b == Ne          , Just s <- getArg (exprSort "extensionality" e1)-       = mytracepp ("extending POS = " ++ showpp expr') <$> (extendRHS ann b e1 e2 s >>= goP Pos)-      goP _ e = return e+       = mytracepp ("extending POS = " ++ showpp e) <$> (extendRHS b e1 e2 s >>= goP Pos) +      goP _ e = return e        goN Neg (PAtom b e1 e2)        | b == Eq || b == Ne        , Just s <- getArg (exprSort "extensionality" e1)-       = mytracepp ("extending NEG = " ++ showpp expr') <$> (extendLHS ann b e1 e2 s >>= goN Neg)-      goN _ e = return e+       = mytracepp ("extending NEG = " ++ showpp e) <$> (extendLHS b e1 e2 s >>= goN Neg) +      goN _ e = return e  -getArg :: Sort -> Maybe Sort-getArg s = case bkFFunc s of-             Just (_, a:_:_) -> Just a-             _                -> Nothing+getArg :: Sort -> Maybe Sort +getArg s = case bkFFunc s of +             Just (_,(a:_:_)) -> Just a +             _                -> Nothing  -extendRHS, extendLHS :: a -> Brel -> Expr -> Expr -> Sort -> Ex a Expr-extendRHS ann b e1 e2 s =-  do es <- generateArguments ann s-     mytracepp "extendRHS = " . pAnd <$> mapM (makeEq b e1 e2) es+extendRHS, extendLHS :: Brel -> Expr -> Expr -> Sort -> Ex Expr+extendRHS b e1 e2 s = +  do es <- generateArguments s +     (mytracepp "extendRHS = " . pAnd) <$> mapM (makeEq b e1 e2) es -extendLHS ann b e1 e2 s =-  do es  <- generateArguments ann s-     dds <- gets exddecl-     is  <- instantiate ann dds s-     mytracepp "extendLHS = " . pAnd . (PAtom b e1 e2:) <$> mapM (makeEq b e1 e2) (es ++ is)+extendLHS b e1 e2 s = +  do es  <- generateArguments s +     dds <- exddecl <$> get +     is  <- instantiate dds s +     (mytracepp "extendLHS = " . pAnd . (PAtom b e1 e2:)) <$> mapM (makeEq b e1 e2) (es ++ is) -generateArguments :: a -> Sort -> Ex a [Expr]-generateArguments ann srt = do-  ddatadecls <- gets exddecl-  case breakSort ddatadecls srt of-    Left dds -> mapM (freshArgDD ann) dds-    Right s  -> (\x -> [EVar x]) <$> freshArgOne ann s -makeEq :: Brel -> Expr -> Expr -> Expr -> Ex ann Expr-makeEq b e1 e2 e = do-  env <- gets exenv-  slv <- gets elabf-  let elab = elaborate (ElabParam slv (dummyLoc "extensionality") env)-  return $ PAtom b (elab $ EApp (unElab e1) e) (elab $ EApp (unElab e2) e)+generateArguments :: Sort -> Ex [Expr]+generateArguments s = do +  st   <- get +  case breakSort (exddecl st) s of +    Left dds -> mapM freshArgDD dds  +    Right s  -> (\x -> [EVar x]) <$> freshArgOne s  -instantiate :: a -> [DataDecl]  -> Sort -> Ex a [Expr]-instantiate ann ds s = instantiateOne ann (breakSort ds s)+makeEq :: Brel-> Expr -> Expr -> Expr -> Ex Expr +makeEq b e1 e2 e = do +  env <- exenv <$> get +  let elab = elaborate (dummyLoc "extensionality") env+  return $ PAtom b (elab $ EApp (unElab e1) e)  (elab $ EApp (unElab e2) e) -instantiateOne :: a -> Either [(LocSymbol, [Sort])] Sort  -> Ex a [Expr]-instantiateOne ann (Right s@(FVar _)) =-  (\x -> [EVar x]) <$> freshArgOne ann s-instantiateOne _ (Right s) = do-  xss <- gets excbs-  return [EVar x | (x,xs) <- xss, xs == s ]-instantiateOne ann (Left [(dc, ts)]) =-  map (mkEApp dc) . combine <$>  mapM (instantiateOne ann) (Right <$> ts)-instantiateOne _ _ = undefined+instantiate :: [DataDecl]  -> Sort -> Ex [Expr]+instantiate ds s = instantiateOne (breakSort ds s)   +instantiateOne :: Either [(LocSymbol, [Sort])] Sort  -> Ex [Expr]+instantiateOne (Right s@(FVar _)) = +  (\x -> [EVar x]) <$> freshArgOne s+instantiateOne (Right s) = do +  xss <- excbs <$> get +  return [EVar x | (x,xs) <- xss, xs == s ] +instantiateOne (Left [(dc, ts)]) = +  (map (mkEApp dc) . combine) <$>  mapM instantiateOne (Right <$> ts) +instantiateOne _ = undefined + combine :: [[a]] -> [[a]] combine []          = [[]] combine ([]:_)      = [] combine ((x:xs):ys) = map (x:) (combine ys) ++ combine (xs:ys)  -data Pos = Pos | Neg deriving Eq-negatePos :: Pos -> Pos-negatePos Pos = Neg-negatePos Neg = Pos+data Pos = Pos | Neg deriving Eq +negatePos :: Pos -> Pos +negatePos Pos = Neg +negatePos Neg = Pos   mapMPosExpr :: (Monad m) => Pos -> (Pos -> Expr -> m Expr) -> Expr -> m Expr-mapMPosExpr pos f = go pos+mapMPosExpr p f = go p    where     go p e@(ESym _)      = f p e     go p e@(ECon _)      = f p e     go p e@(EVar _)      = f p e-    go p e@(PKVar {})      = f p e-    go p (ENeg e)        = f p . ENeg =<< go p e-    go p (ECst e t)      = f p . (`ECst` t) =<< go p e-    go p (ECoerc a t e)  = f p . ECoerc a t =<< go p e+    go p e@(PKVar _ _)   = f p e+    go p (ENeg e)        = f p =<< (ENeg        <$>  go p e                     )+    go p (ECst e t)      = f p =<< ((`ECst` t)  <$>  go p e                     )+    go p (ECoerc a t e)  = f p =<< (ECoerc a t  <$>  go p e                     )     go p (EApp g e)      = f p =<< (EApp        <$>  go p g  <*> go p e             )     go p (EBin o e1 e2)  = f p =<< (EBin o      <$>  go p e1 <*> go p e2            )     go p (PAtom r e1 e2) = f p =<< (PAtom r     <$>  go p e1 <*> go p e2            )      go p (PImp p1 p2)    = f p =<< (PImp        <$>  go (negatePos p) p1 <*> go p p2)-    go p (PAnd ps)       = f p . PAnd =<< (go p `traverse` ps)--    go p (ELet x e1 e2)  = f p =<< ELet x <$> go p e1 <*> go p e2+    go p (PAnd ps)       = f p =<< (PAnd        <$> (go p <$$> ps)                  )      -- The below cannot appear due to normalization-    go p (PNot e)        = f p . PNot =<< go p e+    go p (PNot e)        = f p =<< (PNot        <$>  go p e                     )     go p (PIff p1 p2)    = f p =<< (PIff        <$>  go p p1 <*> go p p2            )     go p (EIte e e1 e2)  = f p =<< (EIte        <$>  go p e  <*> go p e1 <*> go p e2)-    go p (POr  ps)       = f p . POr =<< (go p `traverse` ps)+    go p (POr  ps)       = f p =<< (POr         <$> (go p <$$> ps)                  ) -    -- The following canot appear in general-    go p (PAll xts e)    = f p . PAll   xts =<< go p e-    go p (ELam (x,t) e)  = f p . ELam (x,t) =<< go p e-    go p (PExist xts e)  = f p . PExist xts =<< go p e-    go p (ETApp e s)     = f p . (`ETApp` s) =<< go p e-    go p (ETAbs e s)     = f p . (`ETAbs` s) =<< go p e+    -- The following canot appear in general +    go p (PAll xts e)    = f p =<< (PAll   xts  <$>  go p e                     )+    go p (ELam (x,t) e)  = f p =<< (ELam (x,t)  <$>  go p e                     )+    go p (PExist xts e)  = f p =<< (PExist xts  <$>  go p e                     )+    go p (ETApp e s)     = f p =<< ((`ETApp` s) <$>  go p e                     )+    go p (ETAbs e s)     = f p =<< ((`ETAbs` s) <$>  go p e                     )+    go p (PGrad k s i e) = f p =<< (PGrad k s i <$>  go p e                     ) -normalize :: Expr -> Expr-normalize expr' = mytracepp ("normalize: " ++ showpp expr') $ go expr'-  where+normalize :: Expr -> Expr +normalize e = mytracepp ("normalize: " ++ showpp e) $ go e  +  where      go e@(ESym _)        = e     go e@(ECon _)        = e     go e@(EVar _)        = e-    go e@(PKVar {})        = e+    go e@(PKVar _ _)     = e     go e@(ENeg _)        = e     go (PNot e)          = PImp e PFalse     go e@(ECst _ _)      = e-    go e@ECoerc{}        = e-    go e@(EApp _ _)      = e-    go e@EBin{}          = e+    go e@(ECoerc _ _ _)  = e+    go e@(EApp _ _)      = e +    go e@(EBin _ _ _)    = e      go (PImp p1 p2)      = PImp (go p1) (go p2)     go (PIff p1 p2)      = PAnd [PImp p1' p2', PImp p2' p1'] where (p1', p2') = (go p1, go p2)-    go e@PAtom{}         = e+    go e@(PAtom _ _ _)   = e      go (EIte e e1 e2)    = go $ PAnd [PImp e e1, PImp (PNot e) e2]     go (PAnd ps)         = pAnd (go <$> ps)-    go (POr  ps)         = foldl' (\x y -> PImp (PImp (go x) PFalse) y) PFalse ps-    go e@ELet{}          = e+    go (POr  ps)         = foldl (\x y -> PImp (PImp (go x) PFalse) y) PFalse ps      go e@(PAll _ _)      = e -- Cannot appear     go e@(ELam _ _)      = e -- Cannot appear     go e@(PExist _ _)    = e -- Cannot appear     go e@(ETApp _ _)     = e -- Cannot appear     go e@(ETAbs _ _)     = e -- Cannot appear-+    go e@(PGrad _ _ _ _) = e -- Cannot appear -type Ex a = State (ExSt a)-data ExSt a = ExSt-  { unique  :: Int-  , exddecl :: [DataDecl]-  , exenv   :: SymEnv        -- used for elaboration-  , exbenv  :: BindEnv a-  , exbinds :: IBindEnv-  , excbs   :: [(Symbol, Sort)]-  , elabf   :: ElabFlags-  }+    +type Ex    = State ExSt+data ExSt = ExSt { unique  :: Int+                 , exddecl :: [DataDecl]+                 , exenv   :: SymEnv        -- used for elaboration +                 , exbenv  :: BindEnv+                 , exbinds :: IBindEnv+                 , excbs   :: [(Symbol, Sort)] +                 } -initST :: SymEnv -> [DataDecl] -> ElabFlags -> ExSt ann-initST env dd ef = ExSt 0 (d:dd) env mempty mempty mempty ef-  where+initST :: SymEnv -> [DataDecl]  -> ExSt+initST env dd = ExSt 0 (d:dd) env mempty mempty mempty+  where      -- NV: hardcore Haskell pairs because they do not appear in DataDecl (why?)-#if MIN_TOOL_VERSION_ghc(9,10,1)-    d = mytracepp "Tuple DataDecl" $ DDecl (symbolFTycon (dummyLoc $ symbol "Tuple2")) 2 [ct]-#else-    d = mytracepp "Tuple DataDecl" $ DDecl (symbolFTycon (dummyLoc $ symbol "Tuple")) 2 [ct]-#endif-#if MIN_TOOL_VERSION_ghc(9,6,0) && !MIN_TOOL_VERSION_ghc(9,10,0)-    ct = DCtor (dummyLoc (symbol "GHC.Tuple.Prim.(,)")) [-            DField (dummyLoc (symbol "lqdc$select$GHC.Tuple.Prim.(,)$1")) (FVar 0)-          , DField (dummyLoc (symbol "lqdc$select$GHC.Tuple.Prim.(,)$2")) (FVar 1)-          ]-#elif MIN_TOOL_VERSION_ghc(9,13,0)-    ct = DCtor (dummyLoc (symbol "GHC.Internal.Tuple.(,)")) [-            DField (dummyLoc (symbol "lqdc$select$GHC.Internal.Tuple.(,)$1")) (FVar 0)-          , DField (dummyLoc (symbol "lqdc$select$GHC.Internal.Tuple.(,)$2")) (FVar 1)-          ]-#else+    d = mytracepp "Tuple DataDecl" $ DDecl (symbolFTycon (dummyLoc tupConName)) 2 [ct]     ct = DCtor (dummyLoc (symbol "GHC.Tuple.(,)")) [             DField (dummyLoc (symbol "lqdc$select$GHC.Tuple.(,)$1")) (FVar 0)           , DField (dummyLoc (symbol "lqdc$select$GHC.Tuple.(,)$2")) (FVar 1)           ]-#endif -setBEnv :: BindEnv a -> Ex a ()++setBEnv :: BindEnv -> Ex ()  setBEnv benv = modify (\st -> st{exbenv = benv}) -setExBinds :: IBindEnv -> Ex a ()+setExBinds :: IBindEnv-> Ex () setExBinds bids = modify (\st -> st{ exbinds = bids-                                   , excbs   = [ (x, sr_sort r) | (i, (x, r, _)) <- bindEnvToList (exbenv st)+                                   , excbs   = [ (x, sr_sort r) | (i, x, r) <- bindEnvToList (exbenv st)                                                                 , memberIBindEnv i bids]})  -freshArgDD :: a -> (LocSymbol, [Sort]) -> Ex a Expr-freshArgDD ann (dc, sorts) = do-  xs <- mapM (freshArgOne ann) sorts+freshArgDD :: (LocSymbol, [Sort]) -> Ex Expr +freshArgDD (dc, xs) = do  +  xs <- mapM freshArgOne xs   return $ mkEApp dc (EVar <$> xs)  -freshArgOne :: ann -> Sort -> Ex ann Symbol-freshArgOne ann s = do-  exst <- get-  let x = symbol ("ext$" ++ show (unique exst))-  let (bindId, benv') = insertBindEnv x (trueSortedReft s) ann (exbenv exst)+freshArgOne :: Sort -> Ex Symbol +freshArgOne s = do +  st   <- get +  let x = symbol ("ext$" ++ show (unique st))+  let (id, benv') = insertBindEnv x (trueSortedReft s) (exbenv st)   modify (\st -> st{ exenv   = insertSymEnv x s (exenv st)                    , exbenv  = benv'-                   , exbinds = insertsIBindEnv [bindId] (exbinds st)-                   , unique   = 1 + unique st-                   , excbs = (x,s) : excbs st+                   , exbinds = insertsIBindEnv [id] (exbinds st)+                   , unique   = 1 + (unique st) +                   , excbs = (x,s):(excbs st)                    })-  return x+  return x   -breakSort :: [DataDecl] -> Sort -> Either [(LocSymbol, [Sort])] Sort-breakSort ddatadecls s+breakSort :: [DataDecl] -> Sort -> Either [(LocSymbol, [Sort])] Sort +breakSort ddecls s     | Just (tc, ts) <- splitTC s-    , [(dds,i)] <- [ (ddCtors dd,ddVars dd) | dd <- ddatadecls, ddTyCon dd == tc ]-    = Left ((\dd -> (dcName dd, instSort  (Sub $ zip [0..(i-1)] ts) . dfSort <$> dcFields dd)) <$> dds)-    | otherwise+    , [(dds,i)] <- [ (ddCtors dd,ddVars dd) | dd <- ddecls, ddTyCon dd == tc ] +    = Left ((\dd -> (dcName dd, (instSort  (Sub $ zip [0..(i-1)] ts)) <$> dfSort <$> dcFields dd)) <$> dds)+    | otherwise      = Right s -instSort :: Sub -> Sort -> Sort-instSort (Sub su) x = mapSort go x-  where-    go :: Sort -> Sort-    go (FVar i) = fromMaybe (FVar i) $ lookup i su-    go s        = s-+instSort :: Sub -> Sort -> Sort +instSort (Sub su) x = mapSort go x +  where +    go :: Sort -> Sort +    go (FVar i) = fromMaybe (FVar i) $ lookup i su  +    go s        = s +   splitTC :: Sort -> Maybe (FTycon, [Sort])-splitTC s-     | (FTC f, ts) <- splitFApp s+splitTC s +     | (FTC f, ts) <- splitFApp s       = Just (f, ts)      | otherwise-     = Nothing+     = Nothing   splitFApp :: Sort -> (Sort, [Sort])-splitFApp = go []-    where go acc (FApp s1 s2) = go (s2:acc) s1+splitFApp = go [] +    where go acc (FApp s1 s2) = go (s2:acc) s1            go acc s            = (s, acc)
+ src/Language/Fixpoint/Solver/GradualSolution.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TupleSections      #-}++module Language.Fixpoint.Solver.GradualSolution+  ( -- * Create Initial Solution+    init+  ) where++import           Control.Parallel.Strategies+import qualified Data.HashMap.Strict            as M+import qualified Data.List                      as L+import           Data.Maybe                     (maybeToList, isNothing)+#if !MIN_VERSION_base(4,14,0)+import           Data.Monoid                    ((<>))+#endif+import           Language.Fixpoint.Types.Config+import           Language.Fixpoint.Types.PrettyPrint ()+import qualified Language.Fixpoint.SortCheck          as So+import           Language.Fixpoint.Misc+import qualified Language.Fixpoint.Types              as F+import qualified Language.Fixpoint.Types.Solutions    as Sol+import           Language.Fixpoint.Types.Constraints  hiding (ws, bs)+import           Prelude                              hiding (init, lookup)+import           Language.Fixpoint.Solver.Sanitize  (symbolEnv)+import Language.Fixpoint.SortCheck++--------------------------------------------------------------------------------+-- | Initial Gradual Solution (from Qualifiers and WF constraints) -------------+--------------------------------------------------------------------------------+init :: (F.Fixpoint a) => Config -> F.SInfo a -> [(F.KVar, (F.GWInfo, [F.Expr]))]+--------------------------------------------------------------------------------+init cfg si = map (elab . refineG si qs genv) gs `using` parList rdeepseq +  where+    qs         = F.quals si+    gs         = snd <$> gs0+    genv       = instConstants si++    gs0        = L.filter (isGWfc . snd) $ M.toList (F.ws si)++    elab (k,(x,es)) = ((k,) . (x,)) $ (elaborate (F.atLoc F.dummySpan "init") (sEnv (gsym x) (gsort x)) <$> es)+    +    sEnv x s    = isEnv {F.seSort = F.insertSEnv x s (F.seSort isEnv)}+    isEnv       = symbolEnv cfg si+++--------------------------------------------------------------------------------+refineG :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> (F.KVar, (F.GWInfo, [F.Expr]))+refineG fi qs genv w = (k, (F.gwInfo w, Sol.qbExprs qb))+  where +    (k, qb) = refine fi qs genv w ++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+  where+    env             = wenv <> genv+    wenv            = F.sr_sort <$> F.fromListSEnv (F.envCs (F.bs fi) (F.wenv w))++instConstants :: F.SInfo a -> F.SEnv F.Sort+instConstants = F.fromListSEnv . filter notLit . F.toListSEnv . F.gLits+  where+    notLit    = not . F.isLitSymbol . fst+++refineK :: Bool -> F.SEnv F.Sort -> [F.Qualifier] -> (F.Symbol, F.Sort, F.KVar) -> (F.KVar, Sol.QBind)+refineK ho env qs (v, t, k) = (k, eqs')+   where+    eqs                     = instK ho env v t qs+    eqs'                    = Sol.qbFilter (okInst env v t) eqs++--------------------------------------------------------------------------------+instK :: Bool+      -> F.SEnv F.Sort+      -> F.Symbol+      -> F.Sort+      -> [F.Qualifier]+      -> Sol.QBind+--------------------------------------------------------------------------------+instK ho env v t = Sol.qb . unique . concatMap (instKQ ho env v t)+  where+    unique       = L.nubBy ((. Sol.eqPred) . (==) . Sol.eqPred)++instKQ :: Bool+       -> F.SEnv F.Sort+       -> F.Symbol+       -> F.Sort+       -> F.Qualifier+       -> [Sol.EQual]+instKQ ho env v t q+  = do (su0, v0) <- candidates senv [(t, [v])] qt+       xs        <- match senv tyss [v0] (So.apply su0 <$> qts)+       return     $ Sol.eQual q (reverse xs)+    where+       qt : qts   = qpSort <$> F.qParams q+       tyss       = instCands ho env+       senv       = (`F.lookupSEnvWithDistance` env)++instCands :: Bool -> F.SEnv F.Sort -> [(F.Sort, [F.Symbol])]+instCands ho env = filter isOk tyss+  where+    tyss      = groupList [(t, x) | (x, t) <- xts]+    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.Sort] -> [[F.Symbol]]+match env tyss xs (t : ts)+  = do (su, x) <- candidates env tyss t+       match env tyss (x : xs) (So.apply su <$> ts)+match _   _   xs []+  = return xs++--------------------------------------------------------------------------------+candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.Sort -> [(So.TVSubst, F.Symbol)]+--------------------------------------------------------------------------------+candidates env tyss tx = +    [(su, y) | (t, ys) <- tyss+             , su      <- maybeToList $ So.unifyFast mono env tx t+             , y       <- ys                                   ]+  where+    mono = So.isMono tx++--------------------------------------------------------------------------------+okInst :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> Sol.EQual -> Bool+--------------------------------------------------------------------------------+okInst env v t eq = isNothing tc+  where+    sr            = F.RR t (F.Reft (v, p))+    p             = Sol.eqPred eq+    tc            = So.checkSorted F.dummySpan env sr ++
+ 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
@@ -0,0 +1,820 @@+--------------------------------------------------------------------------------+-- | This module implements "Proof by Logical Evaluation" where we +--   unfold function definitions if they *must* be unfolded, to strengthen+--   the environments with function-definition-equalities. +--   The algorithm is discussed at length in:+-- +--     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842+--     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf +--------------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE ViewPatterns              #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ExistentialQuantification #-}++module Language.Fixpoint.Solver.Instantiate (instantiate) where++import           Language.Fixpoint.Types+import           Language.Fixpoint.Types.Config  as FC+import qualified Language.Fixpoint.Types.Visitor as Vis+import qualified Language.Fixpoint.Misc          as Misc -- (mapFst)+import qualified Language.Fixpoint.Smt.Interface as SMT+import           Language.Fixpoint.Defunctionalize+import qualified Language.Fixpoint.Utils.Trie    as T +import           Language.Fixpoint.Utils.Progress -- as T +import           Language.Fixpoint.SortCheck+import           Language.Fixpoint.Graph.Deps             (isTarget) +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+import qualified Data.List            as L+import qualified Data.Maybe           as Mb -- (isNothing, catMaybes, fromMaybe)+import           Data.Char            (isUpper)+-- import           Debug.Trace          (trace)+-- import           Text.Printf (printf)++mytracepp :: (PPrint a) => String -> a -> a+mytracepp = notracepp ++--------------------------------------------------------------------------------+-- | Strengthen Constraint Environments via PLE +--------------------------------------------------------------------------------+instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instantiate cfg fi subcIds+  | not (oldPLE cfg)+  = PLE.instantiate cfg fi subcIds++  | noIncrPle cfg+  = instantiate' cfg fi subcIds++  | otherwise+  = incrInstantiate' cfg fi subcIds+++------------------------------------------------------------------------------- +-- | 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 -> Maybe [SubcId] -> IO (SInfo a)+------------------------------------------------------------------------------- +incrInstantiate' cfg fi subcIds = do+    let cs = [ (i, c) | (i, c) <- M.toList (cm fi), isPleCstr aEnv i c+                      ,  maybe True (i `L.elem`) subcIds ]+    let t  = mkCTrie cs                                               -- 1. BUILD the Trie+    res   <- withProgress (1 + length cs) $ +               withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs)  -- 2. TRAVERSE Trie to compute InstRes+    return $ resSInfo cfg sEnv fi res                                 -- 3. STRENGTHEN SInfo using InstRes+  where+    file   = srcFile cfg ++ ".evals"+    sEnv   = symbolEnv cfg fi+    aEnv   = ae fi ++++------------------------------------------------------------------------------- +-- | Step 1a: @instEnv@ sets up the incremental-PLE environment +instEnv :: (Loc a) => Config -> SInfo a -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a +instEnv cfg fi cs ctx = InstEnv cfg ctx bEnv aEnv (M.fromList cs) γ s0+  where +    bEnv              = bs fi+    aEnv              = ae fi+    γ                 = knowledge cfg ctx aEnv +    s0                = EvalEnv 0 [] aEnv (SMT.ctxSymEnv ctx) cfg ++---------------------------------------------------------------------------------------------- +-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments +mkCTrie :: [(SubcId, SimpC a)] -> CTrie +mkCTrie ics  = mytracepp  "TRIE" $ T.fromList [ (cBinds c, i) | (i, c) <- ics ]+  where+    cBinds   = L.sort . elemsIBindEnv . senv ++---------------------------------------------------------------------------------------------- +-- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE+pleTrie :: CTrie -> InstEnv a -> IO InstRes+pleTrie t env = loopT env ctx0 diff0 Nothing res0 t +  where +    diff0        = []+    res0         = M.empty +    ctx0         = initCtx es0+    es0          = eqBody <$> L.filter (null . eqArgs) (aenvEqs . ieAenv $ env)++loopT :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CTrie -> IO InstRes+loopT env ctx delta i res t = case t of +  T.Node []  -> return res+  T.Node [b] -> loopB env ctx delta i res b+  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do +                  (ctx'', res') <- ple1 env ctx' i Nothing res +                  foldM (loopB env ctx'' [] i) res' bs++loopB :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CBranch -> IO InstRes+loopB env ctx delta iMb res b = case b of +  T.Bind i t -> loopT env ctx (i:delta) (Just i) res t+  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do +                  progressTick+                  (snd <$> ple1 env ctx' iMb (Just cid) res) +++withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b +withAssms env@(InstEnv {..}) ctx delta cidMb act = do +  let ctx'  = updCtx env ctx delta cidMb +  let assms = mytracepp  ("ple1-assms: " ++ show (cidMb, delta)) (icAssms ctx')+  SMT.smtBracket ieSMT  "PLE.evaluate" $ do+    forM_ assms (SMT.smtAssert ieSMT) +    act ctx'++-- | @ple1@ performs the PLE at a single "node" in the Trie +ple1 :: InstEnv a -> ICtx -> Maybe BindId -> Maybe SubcId -> InstRes -> IO (ICtx, InstRes)+ple1 env@(InstEnv {..}) ctx i cidMb res = do +  let cands = mytracepp  ("ple1-cands: "  ++ show cidMb) $ S.toList (icCands ctx) +  -- unfolds  <- evalCands ieKnowl ieEvEnv cands   +  unfolds  <- evalCandsLoop ieCfg ieSMT ieKnowl ieEvEnv cands   +  return    $ updCtxRes env ctx res i cidMb (mytracepp  ("ple1-cands-unfolds: " ++ show cidMb) unfolds)++_evalCands :: Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] +_evalCands _ _  []    = return []+_evalCands γ s0 cands = do eqs <- mapM (evalOne γ s0) cands+                           return $ mkUnfolds (zip (Just <$> cands) eqs)++unfoldPred :: Config -> SMT.Context -> [Unfold] -> Pred +unfoldPred cfg ctx = toSMT cfg ctx [] . pAnd . concatMap snd  ++evalCandsLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Expr] -> IO [Unfold] +evalCandsLoop cfg ctx γ s0 cands = go [] cands +  where +    go acc []    = return acc +    go acc cands = do eqss   <- SMT.smtBracket ctx "PLE.evaluate" $ do+                                  SMT.smtAssert ctx (unfoldPred cfg ctx acc) +                                  mapM (evalOne γ s0) cands+                      let us  = zip (Just <$> cands) eqss +                      case mkUnfolds us of +                        []  -> return acc +                        us' -> do let acc'   = acc ++ us' +                                  let oks    = S.fromList [ e | (Just e, _) <- us' ]+                                  let cands' = [ e | e <- cands, not (S.member e oks) ] +                                  go acc' cands' +++---------------------------------------------------------------------------------------------- +-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo ++resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a+resSInfo cfg env fi res = strengthenBinds fi res' +  where+    res'     = M.fromList $ mytracepp  "ELAB-INST:  " $ zip is ps''+    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' +    ps'      = defuncAny cfg env ps+    (is, ps) = unzip (M.toList res)++---------------------------------------------------------------------------------------------- +-- | @InstEnv@ has the global information needed to do PLE+data InstEnv a = InstEnv +  { ieCfg   :: !Config+  , ieSMT   :: !SMT.Context+  , ieBEnv  :: !BindEnv+  , ieAenv  :: !AxiomEnv +  , ieCstrs :: !(M.HashMap SubcId (SimpC a))+  , ieKnowl :: !Knowledge+  , ieEvEnv :: !EvalEnv+  } ++-- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE+data ICtx    = ICtx +  { icAssms  :: ![Pred]          -- ^ Hypotheses, already converted to SMT format +  , icCands  :: S.HashSet Expr   -- ^ "Candidates" for unfolding+  , icEquals :: ![Expr]          -- ^ "Known" equalities+  , icSolved :: S.HashSet Expr   -- ^ Terms that we have already expanded+  } ++-- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId+type InstRes = M.HashMap BindId Expr++-- | @Unfold is the result of running PLE at a single equality; +--     (e, [(e1, e1')...]) is the source @e@ and the (possible empty) +--   list of PLE-generated equalities (e1, e1') ... +-- type Unfold  = (Maybe Expr, [(Expr, Expr)])+type Unfold  = (Maybe Expr, [Expr])+type CTrie   = T.Trie   SubcId+type CBranch = T.Branch SubcId+type Diff    = [BindId]    -- ^ in "reverse" order++initCtx :: [Expr] -> ICtx+initCtx es = ICtx +  { icAssms  = [] +  , icCands  = mempty +  , icEquals = mytracepp  "INITIAL-STUFF-INCR" es +  , icSolved = mempty+  }++equalitiesPred :: [(Expr, Expr)] -> [Expr]+equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ] ++updCtxRes :: InstEnv a -> ICtx -> InstRes -> Maybe BindId -> Maybe SubcId -> [Unfold] -> (ICtx, InstRes) +updCtxRes env ctx res iMb cidMb us +                       = -- trace _msg +                         ( ctx { {- icCands  = cands', -} icSolved = solved', icEquals = mempty}+                         , res'+                         ) +  where +    _msg               = Mb.maybe "nuttin\n" (debugResult env res') cidMb+    res'               = updRes res iMb (pAnd solvedEqs) +    _cands'             = ((icCands ctx) `S.union` newCands) `S.difference` solved' +    solved'            = S.union (icSolved ctx) solvedCands +    newCands           = S.fromList (concatMap topApps newEqs) +    solvedCands        = S.fromList [ e | (Just e, _) <- okUnfolds ] +    solvedEqs          = icEquals ctx ++ newEqs +    newEqs             = concatMap snd okUnfolds+    okUnfolds          = mytracepp  _str [ (eMb, ps)  | (eMb, ps) <- us, {- let ps = equalitiesPred eqs, -} not (null ps) ] +    _str               = "okUnfolds " ++ showpp (iMb, cidMb)+    -- cands'             = S.difference (icCands ctx) (S.fromList solvedCands)+    -- solvedEqs          = icEquals ctx ++ concatMap snd us+    -- solvedCands        = [ e          | (Just e, _) <- us]++mkUnfolds :: [(a, [(Expr, Expr)])] -> [(a, [Expr])]+mkUnfolds us = [ (eMb, ps)  | (eMb, eqs) <- us+                            , let ps = equalitiesPred eqs+                            , not (null ps) +               ] ++debugResult :: InstEnv a -> InstRes -> SubcId -> String +debugResult (InstEnv {..}) res i = msg +  where +    msg                          = "INCR-INSTANTIATE i = " ++ show i ++ ": " ++ showpp cidEqs +    cidEqs                       = pAnd [ e | i <- cBinds, e <- Mb.maybeToList $ M.lookup i res ] +    cBinds                       = L.sort . elemsIBindEnv . senv . getCstr ieCstrs $ i+++updRes :: InstRes -> Maybe BindId -> Expr -> InstRes+updRes res (Just i) e = M.insert i e res +updRes res  Nothing _ = res ++-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ +--   to the context. +updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx +updCtx InstEnv {..} ctx delta cidMb +              = ctx { icAssms  = ctxEqs  +                    , icCands  = cands   <> icCands  ctx+                    , icEquals = initEqs <> icEquals ctx }+  where         +    initEqs   = equalitiesPred (initEqualities ieSMT ieAenv bs)+    cands     = (S.fromList (concatMap topApps es0)) `S.difference` (icSolved ctx)+    ctxEqs    = toSMT ieCfg ieSMT [] <$> concat +                  [ initEqs +                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]+                  ]+    (bs, es0) = (second unElabSortedReft <$> binds, unElab <$> es)+    es        = eRhs : (expr <$> binds) +    eRhs      = maybe PTrue crhs subMb+    binds     = [ lookupBindEnv i ieBEnv | i <- delta ] +    subMb     = getCstr ieCstrs <$> cidMb++getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a +getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env++--------------------------------------------------------------------------------+-- | "Old" GLOBAL PLE +--------------------------------------------------------------------------------+instantiate' :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instantiate' cfg fi subcIds = sInfo cfg env fi <$> withCtx cfg file env act+  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+                               ,  maybe True (i `L.elem`) subcIds ]+    file            = srcFile cfg ++ ".evals"+    env             = symbolEnv cfg fi+    aenv            = {- mytracepp  "AXIOM-ENV" -} (ae fi)++sInfo :: Config -> SymEnv -> SInfo a -> [((SubcId, SrcSpan), Expr)] -> SInfo a+sInfo cfg env fi ips = strengthenHyp fi (mytracepp  "ELAB-INST:  " $ zip (fst <$> is) ps'')+  where+    (is, ps)         = unzip ips+    ps'              = defuncAny cfg env ps+    ps''             = zipWith (\(i, sp) -> elaborate (atLoc sp ("PLE1 " ++ show i)) env) is ps' ++instSimpC :: Config -> SMT.Context -> BindEnv -> AxiomEnv -> SubcId -> SimpC a -> IO Expr+instSimpC cfg ctx bds aenv sid sub +  | isPleCstr aenv sid sub = do+    let is0       = mytracepp  "INITIAL-STUFF" $ eqBody <$> L.filter (null . eqArgs) (aenvEqs aenv) +    let (bs, es0) = cstrExprs bds sub+    equalities   <- evaluate cfg ctx aenv bs es0 sid +    let evalEqs   = [ EEq e1 e2 | (e1, e2) <- equalities, e1 /= e2 ] +    return        $ pAnd (is0 ++ evalEqs)  +  | otherwise     = return PTrue++isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool+isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) ++cstrExprs :: BindEnv -> SimpC a -> ([(Symbol, SortedReft)], [Expr])+cstrExprs bds sub = (second unElabSortedReft <$> binds, unElab <$> es)+  where+    es            = (crhs sub) : (expr <$> binds)+    binds         = envCs bds (senv sub)++--------------------------------------------------------------------------------+-- | Symbolic Evaluation with SMT+--------------------------------------------------------------------------------+evaluate :: Config -> SMT.Context -> AxiomEnv -- ^ Definitions+         -> [(Symbol, SortedReft)]            -- ^ Environment of "true" facts +         -> [Expr]                            -- ^ Candidates for unfolding +         -> SubcId                            -- ^ Constraint Id+         -> IO [(Expr, Expr)]                 -- ^ Newly unfolded equalities+--------------------------------------------------------------------------------+evaluate cfg ctx aenv facts es sid = do +  let eqs      = initEqualities ctx aenv facts  +  let γ        = knowledge cfg ctx aenv +  let cands    = mytracepp  ("evaluate-cands " ++ showpp sid) $ Misc.hashNub (concatMap topApps es)+  let s0       = EvalEnv 0 [] aenv (SMT.ctxSymEnv ctx) cfg+  let ctxEqs   = [ toSMT cfg ctx [] (EEq e1 e2) | (e1, e2)  <- eqs ]+              ++ [ toSMT cfg ctx [] (expr xr)   | xr@(_, r) <- facts, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]+  eqss        <- _evalLoop cfg ctx γ s0 ctxEqs cands +  return       $ eqs ++ eqss+++ +_evalLoop :: Config -> SMT.Context -> Knowledge -> EvalEnv -> [Pred] -> [Expr] -> IO [(Expr, Expr)]+_evalLoop cfg ctx γ s0 ctxEqs cands = loop 0 [] cands +  where +    loop _ acc []    = return acc+    loop i acc cands = do let eqp = toSMT cfg ctx [] $ pAnd $ equalitiesPred acc+                          eqss <- SMT.smtBracket ctx "PLE.evaluate" $ do+                                    forM_ (eqp : ctxEqs) (SMT.smtAssert ctx) +                                    mapM (evalOne γ s0) cands+                          case concat eqss of +                            []   -> return acc +                            eqs' -> do let acc'   = acc ++ eqs' +                                       let oks    = S.fromList (fst <$> eqs')+                                       let cands' = [ e | e <- cands, not (S.member e oks) ] +                                       loop (i+1) acc' cands'++++--------------------------------------------------------------------------------+data EvalEnv = EvalEnv+  { evId        :: !Int+  , evSequence  :: [(Expr,Expr)]+  , _evAEnv     :: !AxiomEnv+  , evEnv       :: !SymEnv+  , _evCfg      :: !Config+  }++type EvalST a = StateT EvalEnv IO a+--------------------------------------------------------------------------------++evalOne :: Knowledge -> EvalEnv -> Expr -> IO [(Expr, Expr)]+evalOne γ s0 e = do+  (e', st) <- runStateT (eval γ initCS (mytracepp "evalOne: " e)) s0 +  if e' == e then return [] else return ((e, e') : evSequence st)++{- | [NOTE: Eval-Ite]  We should not be doing any PLE/eval under if-then-else where +     the guard condition does not provably hold. For example, see issue #387.+     However, its ok and desirable to `eval` in this case, as long as one is not +     unfolding recursive functions. To permit this, we track the "call-stack" and +     whether or not, `eval` is occurring under an unresolved guard: if so, we do not +     expand under any function that is already on the call-stack.+  -}++data Recur  = Ok | Stop deriving (Eq, Show)+type CStack = ([Symbol], Recur)++instance PPrint Recur where +  pprintTidy _ = Misc.tshow ++initCS :: CStack +initCS = ([], Ok)++pushCS :: CStack -> Symbol -> CStack +pushCS (fs, r) f = (f:fs, r)++recurCS :: CStack -> Symbol -> Bool +recurCS (_,  Ok) _ = True +-- recurCS (_,  _ ) _ = False -- not (f `elem` fs) +recurCS (fs, _) f  = not (f `elem` fs) ++noRecurCS :: CStack -> CStack +noRecurCS (fs, _) = (fs, Stop)++-- Don't evaluate under Lam, App, Ite, or Constants+topApps :: Expr -> [Expr]+topApps = go +  where +    go (PAnd es)       = concatMap go es+    go (POr es)        = concatMap go es+    go (PAtom _ e1 e2) = go e1  ++ go e2+    go (PIff e1 e2)    = go e1  ++ go e2+    go (PImp e1 e2)    = go e1  ++ go e2+    go (EBin  _ e1 e2) = go e1  ++ go e2+    go (PNot e)        = go e+    go (ENeg e)        = go e+    go e@(EApp _ _)    = [e]+    go _               = []++-- makeLam is the adjoint of splitEApp+makeLam :: Knowledge -> Expr -> Expr+makeLam γ e = L.foldl' (flip ELam) e (knLams γ)++eval :: Knowledge -> CStack -> Expr -> EvalST Expr+eval γ stk = go +  where +    go (ELam (x,s) e)   = ELam (x, s) <$> eval γ' stk e where γ' = γ { knLams = (x, s) : knLams γ }+    go e@(EIte b e1 e2) = go b        >>= \b' -> evalIte γ stk e b' e1 e2+    go (ECoerc s t e)   = ECoerc s t  <$> go e+    go e@(EApp _ _)     = evalArgs γ stk e >>= evalApp γ stk e +    go e@(EVar _)       = evalApp  γ stk e (e, [])+    go (PAtom r e1 e2)  = PAtom r      <$> go e1 <*> go e2+    go (ENeg e)         = ENeg         <$> go e+    go (EBin o e1 e2)   = EBin o       <$> go e1 <*> go e2+    go (ETApp e t)      = flip ETApp t <$> go e+    go (ETAbs e s)      = flip ETAbs s <$> go e+    go (PNot e)         = PNot         <$> go e+    go (PImp e1 e2)     = PImp         <$> go e1 <*> go e2+    go (PIff e1 e2)     = PIff         <$> go e1 <*> go e2+    go (PAnd es)        = PAnd         <$> (go  <$$> es)+    go (POr es)         = POr          <$> (go  <$$> es)+    go e                = return e++(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b]+f <$$> xs = f Misc.<$$> xs++-- | `evalArgs` also evaluates all the partial applications for hacky reasons,+--   suppose `foo g = id` then we want `foo g 10 = 10` and for that we need +--   to `eval` the term `foo g` into `id` to tickle the `eval` on `id 10`.+--   This seems a bit of a hack. At any rate, this can lead to divergence. +--   TODO: distill a .fq test from the MOSSAKA-hw3 example.++evalArgs :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr])+evalArgs γ stk e = go [] e +  where+    go acc (EApp f e)+      = do f' <- evalOk γ stk f+           e' <- eval γ stk e+           go (e':acc) f'+    go acc e+      = (,acc) <$> eval γ stk e++-- | Minimal test case illustrating this `evalOk` hack is LH#tests/ple/pos/MossakaBug.hs+--   too tired & baffled to generate simple .fq version. TODO:nuke and rewrite PLE!+evalOk :: Knowledge -> CStack -> Expr -> EvalST Expr+evalOk γ stk@(_, Ok) e = eval γ stk e +evalOk _ _           e = pure e ++{- +evalArgs :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr])+evalArgs +  | True  = evalArgsOLD +  | False = evalArgsNEW ++evalArgsNEW :: Knowledge -> CStack -> Expr -> EvalST (Expr, [Expr])+evalArgsNEW γ stk e = do +    let (e1, es) = splitEApp e +    e1' <- eval γ stk e1 +    es' <- mapM (eval γ stk) es +    return (e1', es')++-}+    +evalApp :: Knowledge -> CStack -> Expr -> (Expr, [Expr]) -> EvalST Expr+-- evalApp γ stk e (e1, es) = tracepp ("evalApp:END" ++ showpp (e1,es)) <$> (evalAppAc γ stk e (e1, es))+evalApp γ stk e (e1, es) = do +  res     <- evalAppAc γ stk e (e1, es)+  let diff = (res /= (eApps e1 es))+  return   $ mytracepp ("evalApp:END:" ++ showpp diff) res ++evalAppAc :: Knowledge -> CStack -> Expr -> (Expr, [Expr]) -> EvalST Expr++{- MOSSAKA-} +evalAppAc γ stk e (EVar f, [ex])+  | (EVar dc, es) <- splitEApp ex+  , Just simp <- L.find (\simp -> (smName simp == f) && (smDC simp == dc)) (knSims γ)+  , length (smArgs simp) == length es+  = do let msg    = "evalAppAc:ePop: " ++ showpp (f, dc, es)+       let ePopIf = mytracepp msg $ substPopIf (zip (smArgs simp) es) (smBody simp)+       e'    <- eval γ stk ePopIf +       (e, "Rewrite -" ++ showpp f) ~> e'++evalAppAc γ stk _ (EVar f, es)+  -- we should move the lookupKnowledge stuff here into kmAms γ+  | Just eq <- L.find (( == f) . eqName) (knAms γ)+  , Just bd <- getEqBody eq+  , length (eqArgs eq) == length es+  , f `notElem` syms bd               -- non-recursive equations << HACK! misses MUTUALLY RECURSIVE definitions! +  , recurCS stk f +  = do env   <- seSort <$> gets evEnv+       let ee = substEq env PopIf eq es bd+       assertSelectors γ ee +       eval γ (pushCS stk f) ee ++evalAppAc γ stk _e (EVar f, es)+  | Just eq <- L.find ((== f) . eqName) (knAms γ)+  , Just bd <- getEqBody eq+  , length (eqArgs eq) == length es   -- recursive equations+  , recurCS stk f +  = do env      <- seSort <$> gets evEnv+       mytracepp ("EVAL-REC-APP" ++ showpp (stk, _e)) +         <$> evalRecApplication γ (pushCS stk f) (eApps (EVar f) es) (substEq env Normal eq es bd)++evalAppAc _ _ _ (f, es)+  = return (eApps f es)++--------------------------------------------------------------------------------+-- | 'substEq' unfolds or instantiates an equation at a particular list of+--   argument values. We must also substitute the sort-variables that appear+--   as coercions. See tests/proof/ple1.fq+--------------------------------------------------------------------------------+substEq :: SEnv Sort -> SubstOp -> Equation -> [Expr] -> Expr -> Expr+substEq env o eq es bd = substEqVal o eq es (substEqCoerce env eq es bd)++data SubstOp = PopIf | Normal++substEqVal :: SubstOp -> Equation -> [Expr] -> Expr -> Expr+substEqVal o eq es bd = case o of+    PopIf  -> substPopIf     xes  bd+    Normal -> subst (mkSubst xes) bd+  where+    xes    =  zip xs es+    xs     =  eqArgNames eq++substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr -> Expr+substEqCoerce env eq es bd = Vis.applyCoSub coSub bd+  where +    ts    = snd    <$> eqArgs eq+    sp    = panicSpan "mkCoSub"+    eTs   = sortExpr sp env <$> es+    coSub = mytracepp  ("substEqCoerce" ++ showpp (eqName eq, es, eTs, ts)) $ mkCoSub env eTs ts++mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub+mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] +  where+    unite ts    = mytracepp ("UNITE: " ++ showpp ts) $ Mb.fromMaybe (uError ts) (unifyTo1 senv ts)+    senv        = mkSearchEnv env+    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) +    xys         = mytracepp "mkCoSubXXX" $ Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs+    (_xTs,_eTs) = mytracepp "mkCoSub:MATCH" $ (xTs, eTs)++matchSorts :: Sort -> Sort -> [(Symbol, Sort)]+matchSorts s1 s2 = mytracepp  ("matchSorts :" ++ showpp (s1, s2)) $ go s1 s2+  where+    go (FObj x)      {-FObj-} y    = [(x, y)]+    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2+    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2+    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2+    go _             _             = []++--------------------------------------------------------------------------------+getEqBody :: Equation -> Maybe Expr+getEqBody (Equ x xts b _ _)+  | Just (fxs, e) <- getEqBodyPred b+  , (EVar f, es)  <- splitEApp fxs+  , f == x+  , es == (EVar . fst <$> xts)+  = Just e+getEqBody _+  = Nothing++getEqBodyPred :: Expr -> Maybe (Expr, Expr)+getEqBodyPred (PAtom Eq fxs e)+  = Just (fxs, e)+getEqBodyPred (PAnd ((PAtom Eq fxs e):_))+  = Just (fxs, e)+getEqBodyPred _+  = Nothing++eqArgNames :: Equation -> [Symbol]+eqArgNames = map fst . eqArgs++substPopIf :: [(Symbol, Expr)] -> Expr -> Expr+substPopIf xes e = L.foldl' go e xes+  where+    go e (x, EIte b e1 e2) = EIte b (subst1 e (x, e1)) (subst1 e (x, e2))+    go e (x, ex)           = subst1 e (x, ex)++-- see [NOTE:Eval-Ite] the below is wrong; we need to guard other branches too. sigh.++evalRecApplication :: Knowledge -> CStack -> Expr -> Expr -> EvalST Expr+evalRecApplication γ stk e (EIte b e1 e2) = do+  contra <- {- mytracepp  ("CONTRA? " ++ showpp e) <$> -} liftIO (isValid γ PFalse)+  if contra+    then return e+    else do b' <- eval γ stk (mytracepp "REC-APP-COND" b) -- <<<<<<<<<<<<<<<<<<<<< MOSSAKA-LOOP?+            b1 <- liftIO (isValid γ b')+            if b1+              then addEquality γ e 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) >>+                           eval γ stk (mytracepp ("evalREC-2: " ++ showpp stk) e2) >>=+                           ((e, ("App2: " ++ showpp stk ) ) ~>)+                      else return e+evalRecApplication _ _ _ e+  = return e++addEquality :: Knowledge -> Expr -> Expr -> EvalST ()+addEquality γ e1 e2 =+  modify (\st -> st{evSequence = (makeLam γ e1, makeLam γ e2):evSequence st})++evalIte :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> EvalST Expr+evalIte γ stk e b e1 e2 = mytracepp "evalIte:END: " <$> +                            evalIteAc γ stk e b e1 (mytracepp msg e2) +  where +    msg = "evalIte:BEGINS: " ++ showpp (stk, e) +++evalIteAc :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> EvalST Expr+evalIteAc γ stk e b e1 e2 +  = join $ evalIte' γ stk e b e1 e2 <$> liftIO (isValid γ b) <*> liftIO (isValid γ (PNot b))++evalIte' :: Knowledge -> CStack -> Expr -> Expr -> Expr -> Expr -> Bool -> Bool -> EvalST Expr+evalIte' γ stk e _ e1 _ b _+  | b+  = do e' <- eval γ stk e1+       (e, "If-True of:" ++ showpp b)  ~> e'+evalIte' γ stk e _ _ e2 _ b'+  | b'+  = do e' <- eval γ stk e2+       (e, "If-False") ~> e'+evalIte' γ stk _ b e1 e2 _ _+  -- see [NOTE:Eval-Ite] #387 +  = EIte b <$> eval γ stk' e1 <*> eval γ stk' e2 +    where stk' = mytracepp "evalIte'" $ noRecurCS stk ++--------------------------------------------------------------------------------+-- | Knowledge (SMT Interaction)+--------------------------------------------------------------------------------+data Knowledge = KN +  { knSims    :: ![Rewrite]           -- ^ Measure info, asserted for each new Ctor ('assertSelectors')+  , knAms     :: ![Equation]          -- ^ (Recursive) function definitions, used for PLE+  , knContext :: SMT.Context+  , knPreds   :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool+  , knLams    :: [(Symbol, Sort)]+  }++isValid :: Knowledge -> Expr -> IO Bool+isValid γ e = mytracepp ("isValid: " ++ showpp e) <$> +                knPreds γ (knContext γ) (knLams γ) e++isProof :: (a, SortedReft) -> Bool +isProof (_, RR s _) = showpp s == "Tuple"++knowledge :: Config -> SMT.Context -> AxiomEnv -> Knowledge+knowledge cfg ctx aenv = KN +  { knSims    = aenvSimpl aenv+  , knAms     = aenvEqs   aenv+  , knContext = ctx +  , knPreds   = askSMT    cfg +  , knLams    = [] +  } ++-- | This creates the rewrite rule e1 -> e2, applied when:+-- 1. when e2 is a DataCon and can lead to further reductions+-- 2. when size e2 < size e1+initEqualities :: SMT.Context -> AxiomEnv -> [(Symbol, SortedReft)] -> [(Expr, Expr)]+initEqualities ctx aenv es = concatMap (makeSimplifications (aenvSimpl aenv)) dcEqs+  where+    dcEqs                  = Misc.hashNub (Mb.catMaybes [getDCEquality senv e1 e2 | EEq e1 e2 <- atoms])+    atoms                  = splitPAnd =<< (expr <$> filter isProof es)+    senv                   = SMT.ctxSymEnv ctx++-- AT: Non-obvious needed invariant: askSMT True is always the +-- totality-effecting one.+-- RJ: What does "totality effecting" mean? ++askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool+askSMT cfg ctx bs e+  | isTautoPred  e     = return True+  | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e'+  | otherwise          = return False+  where +    e'                 = toSMT cfg ctx bs e ++toSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred+toSMT cfg ctx bs = defuncAny cfg senv . elaborate "makeKnowledge" (elabEnv bs)+  where+    elabEnv      = insertsSymEnv senv+    senv         = SMT.ctxSymEnv ctx++makeSimplifications :: [Rewrite] -> (Symbol, [Expr], Expr) -> [(Expr, Expr)]+makeSimplifications sis (dc, es, e)+     = go =<< sis+ where+   go (SMeasure f dc' xs bd)+     | dc == dc', length xs == length es+     = [(EApp (EVar f) e, subst (mkSubst $ zip xs es) bd)]+   go _+     = []++getDCEquality :: SymEnv -> Expr -> Expr -> Maybe (Symbol, [Expr], Expr)+getDCEquality senv e1 e2+  | Just dc1 <- f1+  , Just dc2 <- f2+  = if dc1 == dc2+      then Nothing+      else error ("isDCEquality on" ++ showpp e1 ++ "\n" ++ showpp e2)+  | Just dc1 <- f1+  = Just (dc1, es1, e2)+  | Just dc2 <- f2+  = Just (dc2, es2, e1)+  | otherwise+  = Nothing+  where+    (f1, es1) = Misc.mapFst (getDC senv) (splitEApp e1)+    (f2, es2) = Misc.mapFst (getDC senv) (splitEApp e2)++-- TODO: Stringy hacks+getDC :: SymEnv -> Expr -> Maybe Symbol+getDC senv (EVar x)+  | isUpperSymbol x && Mb.isNothing (symEnvTheory x senv)+  = Just x+getDC _ _+  = Nothing++isUpperSymbol :: Symbol -> Bool+isUpperSymbol x = (0 < lengthSym x') && (isUpper $ headSym x')+  where +    x' = dropModuleNames x ++dropModuleNames :: Symbol -> Symbol+dropModuleNames = mungeNames (symbol . last) "."+  where+    mungeNames _ _ ""  = ""+    mungeNames f d s'@(symbolText -> s)+      | s' == tupConName = tupConName+      | otherwise        = f $ T.splitOn d $ stripParens s+    stripParens t = Mb.fromMaybe t ((T.stripPrefix "(" >=> T.stripSuffix ")") t)++--------------------------------------------------------------------------------+-- | Creating Measure Info+--------------------------------------------------------------------------------+-- AT@TODO do this for all reflected functions, not just DataCons++{- [NOTE:Datacon-Selectors] The 'assertSelectors' function+   insert measure information for every constructor that appears+   in the expression e.++   In theory, this is not required as the SMT ADT encoding takes+   care of it. However, in practice, some constructors, e.g. from+   GADTs cannot be directly encoded in SMT due to the lack of SMTLIB+   support for GADT. Hence, we still need to hang onto this code.++   See tests/proof/ple2.fq for a concrete example.+ -}++assertSelectors :: Knowledge -> Expr -> EvalST ()+assertSelectors γ e = do+    sims <- aenvSimpl <$> gets _evAEnv+    -- cfg  <- gets evCfg+    -- _    <- foldlM (\_ s -> Vis.mapMExpr (go s) e) (mytracepp  "assertSelector" e) sims+    forM_ sims $ \s -> Vis.mapMExpr (go s) e+    return ()+  where+    go :: Rewrite -> Expr -> EvalST Expr+    go (SMeasure f dc xs bd) e@(EApp _ _)+      | (EVar dc', es) <- splitEApp e+      , dc == dc'+      , length xs == length es+      = do let e1 = EApp (EVar f) e+           let e2 = subst (mkSubst $ zip xs es) bd+           addEquality γ e1 e2+           return e+    go _ e+      = return e++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++withCtx :: Config -> FilePath -> SymEnv -> (SMT.Context -> IO a) -> IO a+withCtx cfg file env k = do+  ctx <- SMT.makeContextWithSEnv cfg file env+  _   <- SMT.smtPush ctx+  res <- k ctx+  _   <- SMT.cleanupContext ctx+  return res++(~>) :: (Expr, String) -> Expr -> EvalST Expr+(e, _str) ~> e' = do+  let msg = "PLE: " ++ _str ++ showpp (e, e') +  modify (\st -> st {evId = (mytracepp msg $ evId st) + 1})+  return e'+
− src/Language/Fixpoint/Solver/Interpreter.hs 
@@ -1,741 +0,0 @@------------------------------------------------------------------------------------ | This module is a preliminary part of the implementation of "Proof by---   Logical Evaluation" where we unfold function definitions if they *must* be---   unfolded, to strengthen the environments with function-definition-equalities.------   In this module, we attempt to verify as many of the PLE constaints as---   possible without invoking the SMT solver or performing any I/O at all.---   To this end, we use an interpreter in Haskell to attempt to evaluate down---   expressions and generate equalities.-----------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ExistentialQuantification #-}--module Language.Fixpoint.Solver.Interpreter-  ( instInterpreter--  -- The following exports are for property testing.-  , ICtx(..)-  , Knowledge(..)-  , Simplifiable(..)-  , interpret-  ) where--import           Language.Fixpoint.Types hiding (simplify)-import           Language.Fixpoint.Types.Config  as FC-import           Language.Fixpoint.Types.Solutions        (CMap)-import qualified Language.Fixpoint.Types.Visitor as Vis-import qualified Language.Fixpoint.Misc          as Misc-import           Language.Fixpoint.Defunctionalize-import qualified Language.Fixpoint.Utils.Trie    as T-import           Language.Fixpoint.Utils.Progress-import           Language.Fixpoint.SortCheck-import           Language.Fixpoint.Graph.Deps             (isTarget)-import           Language.Fixpoint.Solver.Sanitize        (symbolEnv)-import           Language.Fixpoint.Solver.Simplify-import           Control.Monad (foldM)-import           Control.Monad.State-import qualified Data.HashMap.Strict  as M-import qualified Data.HashSet         as S-import qualified Data.List            as L-import qualified Data.Maybe           as Mb---import           Debug.Trace                              (trace)--mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp----mytrace :: String -> a -> a---mytrace = {-trace-} flip const------------------------------------------------------------------------------------- | Strengthen Constraint Environments via PLE----------------------------------------------------------------------------------instInterpreter :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (BindEnv a)-instInterpreter cfg fi' subcIds = do-    let cs = M.filterWithKey-               (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds)-               (cm info)-    let t  = mkCTrie (M.toList cs)                      -- 1. BUILD the Trie-    res   <- withProgress (1 + M.size cs) $-               pleTrie t $ instEnv info cs sEnv         -- 2. TRAVERSE Trie to compute InstRes-    return $ resSInfo cfg sEnv info res                 -- 3. STRENGTHEN SInfo using InstRes-  where-    sEnv   = symbolEnv cfg info-    aEnv   = ae info-    info   = normalize fi'------------------------------------------------------------------------------------ | Step 1a: @instEnv@ sets up the incremental-PLE environment-instEnv :: (Loc a) => SInfo a -> CMap (SimpC a) -> SymEnv -> InstEnv a-instEnv info cs sEnv = InstEnv bEnv aEnv cs γ s0-  where-    csBinds           = M.foldl' (\acc c -> unionIBindEnv acc (senv c)) emptyIBindEnv cs-    bEnv              = filterBindEnv (\i _ _ -> memberIBindEnv i csBinds) (bs info)-    aEnv              = ae info-    γ                 = knowledge info-    s0                = EvalEnv sEnv mempty--------------------------------------------------------------------------------------------------- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments-mkCTrie :: [(SubcId, SimpC a)] -> CTrie-mkCTrie ics  = T.fromList [ (cBinds c, i) | (i, c) <- ics ]-  where-    cBinds   = L.sort . elemsIBindEnv . senv--------------------------------------------------------------------------------------------------- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE-pleTrie :: CTrie -> InstEnv a -> IO InstRes-pleTrie t env = loopT env ctx0 diff0 Nothing res0 t-  where-    diff0        = []-    res0         = M.empty-    ctx0         = initCtx env ((mkEq <$> es0) ++ (mkEq' <$> es0'))-    es0          = L.filter (null . eqArgs) (aenvEqs   . ieAenv $ env)-    es0'         = L.filter (null . smArgs) (aenvSimpl . ieAenv $ env)-    mkEq  eq     = (EVar $ eqName eq, eqBody eq)-    mkEq' rw     = (EApp (EVar $ smName rw) (EVar $ smDC rw), smBody rw)--loopT :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CTrie -> IO InstRes-loopT env ctx delta i res t = case t of-  T.Node []  -> return res-  T.Node [b] -> loopB env ctx delta i res b-  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do-                  (ctx'', res') <- ple1 env ctx' i res-                  foldM (loopB env ctx'' [] i) res' bs--loopB :: InstEnv a -> ICtx -> Diff -> Maybe BindId -> InstRes -> CBranch -> IO InstRes-loopB env ctx delta iMb res b = case b of-  T.Bind i t -> loopT env ctx (i:delta) (Just i) res t-  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do-                  progressTick-                  snd <$> ple1 env ctx' iMb res---- Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@--- and the rhs of @cidMb@.------ Adds to @ctx@ assumptions from @env@ and @delta@ plus rewrites that--- candidates can use-withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b-withAssms env@InstEnv{} ctx delta cidMb act = act $-  updCtx env ctx delta cidMb---- | @ple1@ performs the PLE at a single "node" in the Trie-ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstRes)-ple1 InstEnv{..} ctx i res =-  updCtxRes res i <$> evalCandsLoop {-anfEnv-} M.empty ctx ieKnowl ieEvEnv--evalCandsLoop :: ConstMap -> ICtx -> Knowledge -> EvalEnv -> IO ICtx-evalCandsLoop ie ictx0 γ env = go ictx0-  where-    withRewrites exprs =-      let-        sortEnv = seSort (evEnv env)-        rws = [rewrite sortEnv e rw | rw <- snd <$> M.toList (knSims γ)-                            ,  e <- S.toList (snd `S.map` exprs)]-      in-        exprs <> S.fromList (concat rws)-    go ictx | S.null (icCands ictx) = return ictx-    go ictx =  do let cands = icCands ictx-                  let env' = env { evAccum = icEquals ictx <> evAccum env }-                  (ictx', evalResults)  <--                               foldM (evalOneCandStep ie γ env') (ictx, []) (S.toList cands)-                  let us = mconcat evalResults-                  if S.null (us `S.difference` icEquals ictx)-                        then return ictx-                        else do  let oks      = fst `S.map` us-                                 let us'      = withRewrites us-                                 let ictx''   = ictx' { icSolved = icSolved ictx <> oks-                                                      , icEquals = icEquals ictx <> us' }-                                 let newcands = mconcat (makeCandidates γ ictx'' <$> S.toList (cands <> (snd `S.map` us)))-                                 go (ictx'' { icCands = S.fromList newcands})---- evalOneCands :: Knowledge -> EvalEnv -> ICtx -> [Expr] -> IO (ICtx, [EvAccum])--- evalOneCands γ env' ictx = foldM step (ictx, [])-evalOneCandStep :: ConstMap -> Knowledge -> EvalEnv -> (ICtx, [EvAccum]) -> Expr -> IO (ICtx, [EvAccum])-evalOneCandStep env γ env' (ictx, acc) e = do-  res <- evalOne env γ env' ictx e-  return (ictx, res : acc)--rewrite :: SEnv Sort -> Expr -> Rewrite -> [(Expr,Expr)]-rewrite env e rw = filter (wellSorted env . fst) $ Mb.mapMaybe (`rewriteTop` rw) (notGuardedApps e)--rewriteTop :: Expr -> Rewrite -> Maybe (Expr,Expr)-rewriteTop e rw-  | (EVar f, es) <- splitEApp e-  , f == smDC rw-  , length es == length (smArgs rw)-  = Just (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw))-  | otherwise-  = Nothing---- | Check that an expression is well-sorted-wellSorted :: SEnv Sort -> Expr -> Bool-wellSorted env = Mb.isJust . checkSortExpr dummySpan env--------------------------------------------------------------------------------------------------- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo-------------------------------------------------------------------------------------------------resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> BindEnv a-resSInfo cfg env info res = strengthenBinds info res'-  where-    res'     = M.fromList $ zip is ps''-    ps''     = zipWith (\i -> elaborate (ElabParam (solverFlags cfg) (atLoc dummySpan ("PLE1 " ++ show i)) env)) is ps'-    ps'      = defuncAny cfg env ps-    (is, ps) = unzip (M.toList res)--------------------------------------------------------------------------------------------------- | @InstEnv@ has the global information needed to do PLE-------------------------------------------------------------------------------------------------data InstEnv a = InstEnv-  { ieBEnv  :: !(BindEnv a)-  , ieAenv  :: !AxiomEnv-  , ieCstrs :: !(CMap (SimpC a))-  , ieKnowl :: !Knowledge-  , ieEvEnv :: !EvalEnv-  }--------------------------------------------------------------------------------------------------- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE-------------------------------------------------------------------------------------------------data ICtx    = ICtx-  { icCands    :: S.HashSet Expr            -- ^ "Candidates" for unfolding-  , icEquals   :: EvAccum                   -- ^ Accumulated equalities-  , icSolved   :: S.HashSet Expr            -- ^ Terms that we have already expanded-  , icSimpl    :: !ConstMap                 -- ^ Map of expressions to constants-  , icSubcId   :: Maybe SubcId              -- ^ Current subconstraint ID-  }--------------------------------------------------------------------------------------------------- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId-------------------------------------------------------------------------------------------------type InstRes = M.HashMap BindId Expr--------------------------------------------------------------------------------------------------- | @Unfold is the result of running PLE at a single equality;---     (e, [(e1, e1')...]) is the source @e@ and the (possible empty)---   list of PLE-generated equalities (e1, e1') ...-------------------------------------------------------------------------------------------------type CTrie   = T.Trie   SubcId-type CBranch = T.Branch SubcId-type Diff    = [BindId]    -- ^ in "reverse" order--initCtx :: InstEnv a -> [(Expr,Expr)] -> ICtx-initCtx _   es   = ICtx-  { icCands  = mempty-  , icEquals = S.fromList es-  , icSolved = mempty-  , icSimpl  = mempty-  , icSubcId = Nothing-  }--equalitiesPred :: S.HashSet (Expr, Expr) -> [Expr]-equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- S.toList eqs, e1 /= e2 ]--updCtxRes :: InstRes -> Maybe BindId -> ICtx -> (ICtx, InstRes)-updCtxRes res iMb ctx = (ctx, res')-  where-    res' = updRes res iMb (pAnd $ equalitiesPred $ icEquals ctx)---updRes :: InstRes -> Maybe BindId -> Expr -> InstRes-updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res-updRes res  Nothing _ = res---------------------------------------------------------------------------------------------------- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@---   to the context.-------------------------------------------------------------------------------------------------updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx-updCtx InstEnv{..} ctx delta cidMb-    = ctx { icCands  = S.fromList cands           <> icCands  ctx-          , icEquals = initEqs                    <> icEquals ctx-          , icSimpl  = M.fromList (S.toList sims) <> icSimpl ctx <> econsts-          , icSubcId = cidMb -- fst <$> L.find (\(_, b) -> (head delta) `memberIBindEnv` (_cenv b)) ieCstrs-          }                  -- eliminate above if nothing broken-  where-    initEqs   = S.fromList $ concat [rewrite sortEnv e rw | e  <- cands ++ (snd <$> S.toList (icEquals ctx))-                                                  , rw <- snd <$> M.toList (knSims ieKnowl)]-    sortEnv   = seSort (evEnv ieEvEnv)-    cands     = concatMap (makeCandidates ieKnowl ctx) (rhs:es)-    sims      = S.filter (isSimplification (knDCs ieKnowl)) (initEqs <> icEquals ctx)-    econsts   = M.fromList $ findConstants ieKnowl es-    rhs       = unElab eRhs-    es        = unElab . expr <$> [ (x, y) | (x, y,_ ) <- binds ]-    eRhs      = maybe PTrue crhs subMb-    binds     = [ lookupBindEnv i ieBEnv | i <- delta ]-    subMb     = getCstr ieCstrs <$> cidMb---findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]-findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)]-  where-    go su ess = if ess == ess'-                  then su-                  else go (su ++ su') ess'-       where ess' = subst (mkSubst su') <$> ess-             su'  = makeSu ess-    makeSu exprs  = [(x,c) | (EEq (EVar x) c) <- exprs-                           , isConstant (knDCs γ) c-                           , EVar x /= c ]--makeCandidates :: Knowledge -> ICtx -> Expr -> [Expr]-makeCandidates k ctx exprs-  = mytracepp ("\n" ++ show (length cands) ++ " New Candidates") cands-  where-    cands =-      filter (\e -> isRedex k e && not (e `S.member` icSolved ctx)) (notGuardedApps exprs) ++-      filter (\e -> hasConstructors k e && not (e `S.member` icSolved ctx)) (largestApps exprs)--    -- Constructor occurrences need to be considered as candidadates since-    -- they identify relevant measure equations. The function 'rewrite'-    -- introduces these equations.-    hasConstructors :: Knowledge -> Expr -> Bool-    hasConstructors γ e =  not $ S.null $ S.intersection (exprSymbolsSet e) (knDCs γ)--isRedex :: Knowledge -> Expr -> Bool-isRedex γ e = isGoodApp γ e || isIte e-  where-    isIte EIte {} = True-    isIte _       = False---isGoodApp :: Knowledge -> Expr -> Bool-isGoodApp γ e-  | (EVar f, es) <- splitEApp e-  , Just i       <- L.lookup f (knSummary γ)-  = length es >= i-  | otherwise-  = False-----getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a-getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env--isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool-isPleCstr aenv subid c = isTarget c && M.lookupDefault False subid (aenvExpand aenv)--type EvAccum = S.HashSet (Expr, Expr)-----------------------------------------------------------------------------------data EvalEnv = EvalEnv-  { evEnv      :: !SymEnv-  , evAccum    :: EvAccum-  }--type EvalST a = StateT EvalEnv IO a------------------------------------------------------------------------------------evalOne :: ConstMap -> Knowledge -> EvalEnv -> ICtx -> Expr -> IO EvAccum-evalOne ienv γ env ctx e {- null (getAutoRws γ ctx) -} = do-    (e', st) <- runStateT (fastEval ienv γ ctx e) env-    let evAcc' = if mytracepp ("evalOne: " ++ showpp e) e' == e then evAccum st else S.insert (e, e') (evAccum st)-    return evAcc'--notGuardedApps :: Expr -> [Expr]-notGuardedApps = flip go []-  where-    go e0 acc = case e0 of-      EApp e1 e2 -> e0 : go e1 (go e2 acc)-      PAnd es    -> foldr go acc es-      POr es     -> foldr go acc es-      PAtom _ e1 e2 -> go e1 $ go e2 acc-      PIff e1 e2 -> go e1 $ go e2 acc-      PImp e1 e2 -> go e1 $ go e2 acc-      EBin  _ e1 e2 -> go e1 $ go e2 acc-      PNot e -> go e acc-      ENeg e -> go e acc-      EIte b _ _ -> go b $ e0 : acc-      ECoerc _ _ e -> go e acc-      ECst e _ -> go e acc-      ELet{} -> acc-      ESym _ -> acc-      ECon _ -> acc-      EVar _ -> acc-      ELam _ _ -> acc-      ETApp _ _ -> acc-      ETAbs _ _ -> acc-      PKVar {} -> acc-      PAll _ _ -> acc-      PExist _ _ -> acc--largestApps :: Expr -> [Expr]-largestApps = flip go []-  where-    go e0 acc = case e0 of-      EApp _ _ -> e0 : acc-      PAnd es -> foldr go acc es-      POr es -> foldr go acc es-      PAtom _ e1 e2 -> go e1 $ go e2 acc-      PIff e1 e2 -> go e1 $ go e2 acc-      PImp e1 e2 -> go e1 $ go e2 acc-      EBin  _ e1 e2 -> go e1 $ go e2 acc-      PNot e -> go e acc-      ENeg e -> go e acc-      EIte b _ _ -> go b $ e0 : acc-      ECoerc _ _ e -> go e acc-      ECst e _ -> go e acc-      ESym _ -> acc-      ECon _ -> acc-      EVar _ -> e0 : acc-      ELet{} -> acc-      ELam _ _ -> acc-      ETApp _ _ -> acc-      ETAbs _ _ -> acc-      PKVar {} -> acc-      PAll _ _ -> acc-      PExist _ _ -> acc--fastEval :: ConstMap -> Knowledge -> ICtx -> Expr -> EvalST Expr-fastEval ienv γ ctx e-    = do env  <- gets (seSort . evEnv)-         return $ mytracepp ("evaluating" ++ show e) $ interpret ienv γ ctx env $ simplify γ ctx e------------------------------------------------------------------------------------- | 'substEq' unfolds or instantiates an equation at a particular list of---   argument values. We must also substitute the sort-variables that appear---   as coercions. See tests/proof/ple1.fq-----------------------------------------------------------------------------------unfoldExpr :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> {-EvalST-} Expr-unfoldExpr ie γ ctx env (EIte e0 e1 e2) = let g' = interpret' ie γ ctx env e0 in-                                             if g' == PTrue-                                                then unfoldExpr ie γ ctx env e1-                                                else if g' == PFalse-                                                        then unfoldExpr ie γ ctx env e2-                                                        else EIte g' e1 e2-unfoldExpr _  _ _   _   e               = e--substEq :: SEnv Sort -> Equation -> [Expr] -> Expr-substEq env eq es = subst su (substEqCoerce env eq es)-  where su = mkSubst $ zip (eqArgNames eq) es--substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr-substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq-  where-    ts    = snd    <$> eqArgs eq-    sp    = panicSpan "mkCoSub"-    eTs   = sortExpr sp env <$> es-    coSub = mkCoSub env eTs ts--mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub-mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ]-  where-    unite ts    = Mb.fromMaybe (uError ts) (unifyTo1 symToSearch ts)-    symToSearch = mkSearchEnv env-    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts)-    xys         = Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs-    (_xTs,_eTs) = (xTs, eTs)--matchSorts :: Sort -> Sort -> [(Symbol, Sort)]-matchSorts = go-  where-    go (FObj x)      {-FObj-} y    = [(x, y)]-    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2-    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2-    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2-    go _             _             = []------------------------------------------------------------------------------------eqArgNames :: Equation -> [Symbol]-eqArgNames = map fst . eqArgs--interpret' :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr-interpret' ie γ ctx env e = mytracepp ("Interpreting " ++ show e) $ interpret ie γ ctx env e--interpret :: ConstMap -> Knowledge -> ICtx -> SEnv Sort -> Expr -> Expr-interpret _  _ _   _   e@(ESym _)       = e-interpret _  _ _   _   e@(ECon _)       = e-interpret ie γ ctx env (EVar sym)-    | Just e' <- M.lookup (EVar sym) (icSimpl ctx)-    = interpret' ie γ ctx env e'-interpret _  _ _   _   e@(EVar _)       = e-interpret ie γ ctx env   (EApp e1 e2)-  | isSetPred e1                        = let e2' = interpret' ie γ ctx env e2 in-                                             applySetFolding e1 e2'-interpret cmap know ictx ssenv e@(EApp _ _)     = case splitEApp e of-  (exprs, exprses) -> let g = interpret' cmap know ictx ssenv in-    interpretApp cmap know ictx ssenv (g exprs) (map g exprses)-    where-      interpretApp ie γ ctx env (EVar f) es-        | Just eq <- M.lookup f (knAms γ)-        , length (eqArgs eq) <= length es-        = let (es1,es2) = splitAt (length (eqArgs eq)) es-              ges       = substEq env eq es1-              exp1      = unfoldExpr ie γ ctx env ges-              exp2      = eApps exp1 es2 in  --exp' -- TODO undo-            if eApps (EVar f) es == exp2 then exp2 else interpret' ie γ ctx env exp2--      interpretApp ie γ ctx env (EVar f) (e1:es)-        | (EVar dc, as) <- splitEApp e1-        , Just rw <- M.lookup (f, dc) (knSims γ)-        , length as == length (smArgs rw)-        = let e' = eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es in --e' -- TODO undo-            if eApps (EVar f) es == e' then e' else interpret' ie γ ctx env e'--      interpretApp _  γ _   _   (EVar f) [e0]-        | (EVar dc, _as) <- splitEApp e0-        , isTestSymbol f-        = if testSymbol dc == f then PTrue else-            if S.member dc (knAllDCs γ) then PFalse else {-simplify γ ctx $-} eApps (EVar f) [e0]--      interpretApp _  _ _   _   f        es     = {-simplify γ ctx $-} eApps f es-interpret ie γ ctx env   (ENeg e1)      = let e1' = interpret' ie γ ctx env e1 in-                                            applyConstantFolding Minus (ECon (I 0)) e1'---                                          simplify γ ctx (ENeg e1')-interpret ie γ ctx env   (EBin o e1 e2) = let e1' = interpret' ie γ ctx env e1-                                              e2' = interpret' ie γ ctx env e2 in-                                            applyConstantFolding o e1' e2'---                                          simplify γ ctx (EBin o e1' e2')-interpret ie γ ctx env   (EIte g e1 e2) = let b = interpret' ie γ ctx env g in-                                            if b == PTrue then interpret' ie γ ctx env e1 else-                                              if b == PFalse then interpret' ie γ ctx env e2 else-                                                simplify γ ctx $ EIte b e1 e2---                                          EIte b (interpret' γ ctx env e1) (interpret' γ ctx env e2)-interpret ie γ ctx env   (ECst e1 s)    = let e1' = interpret' ie γ ctx env e1 in-                                            simplifyCasts e1' s -- ECst e1' s-interpret ie γ ctx env (ELam (x,s) e)   = let γ' = γ { knLams = (x, s) : knLams γ }-                                              e' = interpret' ie γ' ctx env e in-                                            ELam (x, s) e'-interpret ie γ ctx env   (ETApp e1 t)   = let e1' = interpret' ie γ ctx env e1 in ETApp e1' t-interpret ie γ ctx env   (ETAbs e1 sy)  = let e1' = interpret' ie γ ctx env e1 in ETAbs e1' sy-interpret ie γ ctx env   (PAnd exprses) = let es' = map (interpret' ie γ ctx env) exprses in go [] (reverse es')-  where-    go []  []         = PTrue-    go [p] []         = interpret' ie γ ctx env p-    go acc []         = PAnd acc-    go acc (PTrue:es) = go acc es-    go _   (PFalse:_) = PFalse-    go acc (e:es)     = go (e:acc) es-interpret ie γ ctx env (POr exprses)      = let es' = map (interpret' ie γ ctx env) exprses in go [] (reverse es')-  where-    go []  []          = PFalse-    go [p] []          = interpret' ie γ ctx env p-    go acc []          = POr acc-    go _   (PTrue:_)   = PTrue-    go acc (PFalse:es) = go acc es-    go acc (e:es)      = go (e:acc) es-interpret ie γ ctx env (PNot e)         = let e' = interpret' ie γ ctx env e in case e' of-    (PNot e'')    -> e''-    PTrue         -> PFalse-    PFalse        -> PTrue-    _             -> PNot e'-interpret ie γ ctx env (PImp e1 e2)     = let e1' = interpret' ie γ ctx env e1-                                              e2' = interpret' ie γ ctx env e2 in-                                            if e1' == PFalse || e2' == PTrue then PTrue else-                                              if e1' == PTrue then e2' else-                                                if e2' == PFalse then interpret' ie γ ctx env (PNot e1') else-                                                  PImp e1' e2'-interpret ie γ ctx env (PIff e1 e2)     = let e1' = interpret' ie γ ctx env e1-                                              e2' = interpret' ie γ ctx env e2 in-                                            if e1' == PTrue then e2' else-                                              if e2' == PTrue then e1' else-                                                if e1' == PFalse then interpret' ie γ ctx env (PNot e2') else-                                                  if e2' == PFalse then interpret' ie γ ctx env (PNot e1') else-                                                    PIff e1' e2'-interpret ie γ ctx env (PAtom o e1 e2)  = let e1' = interpret' ie γ ctx env e1-                                              e2' = interpret' ie γ ctx env e2 in-                                            applyBooleanFolding o e1' e2'-interpret _  _ _   _   e@(PKVar {})       = e-interpret ie γ ctx env e@(PAll xss e1)  = case xss of-  [] -> interpret' ie γ ctx env e1-  _  -> e-interpret ie γ ctx env e@(PExist xss e1) = case xss of-  [] -> interpret' ie γ ctx env e1-  _  -> e-interpret ie γ ctx env (ECoerc s t e)    = let e' = interpret' ie γ ctx env e in-                                             if s == t then e' else ECoerc s t e'-interpret ie γ ctx env (ELet x e1 e2)    = let e1' = interpret' ie γ ctx env e1-                                               e2' = interpret' ie γ ctx env e2 in-                                             ELet x e1' e2'-------------------------------------------------------------------------------------- | Knowledge (SMT Interaction)----------------------------------------------------------------------------------data Knowledge = KN-  { knSims              :: M.HashMap (Symbol, Symbol) Rewrite  -- ^ Rewrite rules came from match and data type definitions-  , knAms               :: M.HashMap Symbol Equation  -- ^ All function definitions -- restore ! here?-  , knLams              :: ![(Symbol, Sort)]-  , knSummary           :: ![(Symbol, Int)]     -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity-  , knDCs               :: !(S.HashSet Symbol)  -- ^ data constructors drawn from Rewrite-  , knAllDCs            :: !(S.HashSet Symbol)  -- ^-  , knSels              :: !SelectorMap-  , knConsts            :: !ConstDCMap-  }--knowledge :: SInfo a -> Knowledge-knowledge info = KN-  { knSims                     = M.fromList $ (\r -> ((smName r, smDC r), r)) <$> sims-  , knAms                      = M.fromList $ (\a -> (eqName a, a)) <$> aenvEqs aenv-  , knLams                     = []-  , knSummary                  =    ((\s -> (smName s, 1)) <$> sims)-                                 ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)-  , knDCs                      = S.fromList (smDC <$> sims)  <> constNames info-  , knAllDCs                   = S.fromList $ val . dcName <$> concatMap ddCtors (ddecls info)-  , knSels                     = M.fromList $ Mb.mapMaybe makeSel  sims-  , knConsts                   = M.fromList $ Mb.mapMaybe makeCons sims-  }-  where-    sims = aenvSimpl aenv-    aenv = ae info--    makeCons rw-      | null (syms $ smBody rw)-      = Just (smName rw, (smDC rw, smBody rw))-      | otherwise-      = Nothing--    makeSel rw-      | EVar x <- smBody rw-      = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw)-      | otherwise-      = Nothing--    constNames si = (S.fromList . map fst . toListSEnv . gLits $ si) `S.union`-                      (S.fromList . map fst . toListSEnv . dLits $ si)--- testSymbol (from names)--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi,--- i.e., sel_i selects the ith value for the data constructor D-type SelectorMap = M.HashMap Symbol (Symbol, Int)-type ConstDCMap  = M.HashMap Symbol (Symbol, Expr)---- ValueMap maps expressions to constants (including data constructors)-type ConstMap = M.HashMap Expr Expr-type LDataCon = Symbol              -- Data Constructors--isSimplification :: S.HashSet LDataCon -> (Expr,Expr) -> Bool-isSimplification dcs (_,c) = isConstant dcs c--isConstant :: S.HashSet LDataCon -> Expr -> Bool-isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs)--class Simplifiable a where-  simplify :: Knowledge -> ICtx -> a -> a---instance Simplifiable Expr where-  simplify γ ictx exprs = mytracepp ("simplification of " ++ show exprs) $ fix' (Vis.mapExpr tx) exprs-    where-      fix' f e = if e == e' then e else fix' f e' where e' = f e-      tx e-        | Just e' <- M.lookup e (icSimpl ictx)-        = e'--      tx (PAtom rel e1 e2) = applyBooleanFolding rel e1 e2-      tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2-      tx (ENeg e)         = applyConstantFolding Minus (ECon (I 0)) e-      tx (EApp e1 e2)-        | isSetPred e1    = applySetFolding e1 e2--      tx (EApp (EVar f) a)-        | Just (dc, c)  <- M.lookup f (knConsts γ)-        , (EVar dc', _) <- splitEApp a-        , dc == dc'-        = c-      tx (EIte b e1 e2)-        | isTautoPred b  = e1-        | isContraPred b = e2-      tx (ECst e s)       = simplifyCasts e s-      tx (ECoerc s t e)-        | s == t = e-      tx (EApp (EVar f) a)-        | Just (dc, i)  <- M.lookup f (knSels γ)-        , (EVar dc', es) <- splitEApp a-        , dc == dc'-        = es!!i-      tx (PAnd exprses)         = go [] (reverse exprses)-        where-          go []  []     = PTrue-          go [p] []     = p-          go acc []     = PAnd acc-          go acc (e:es)-            | e == PTrue = go acc es-            | e == PFalse = PFalse-            | otherwise = go (e:acc) es-      tx (POr exprses)          = go [] (reverse exprses)-        where-          go []  []     = PFalse-          go [p] []     = p-          go acc []     = POr acc-          go acc (e:es)-            | e == PTrue = PTrue-            | e == PFalse = go acc es-            | otherwise = go (e:acc) es-      tx (PNot e)-        | e == PTrue = PFalse-        | e == PFalse = PTrue-        | otherwise = PNot e-      tx e = e--simplifyCasts :: Expr -> Sort -> Expr-simplifyCasts (ECon (I n)) FInt  = ECon (I n)-simplifyCasts (ECon (R x)) FReal = ECon (R x)-simplifyCasts e            s     = ECst e s------------------------------------------------------------------------------------ | Normalization of Equation: make their arguments unique -----------------------------------------------------------------------------------------------------class Normalizable a where-  normalize :: a -> a--instance Normalizable (GInfo c a) where-  normalize si = si {ae = normalize $ ae si}--instance Normalizable AxiomEnv where-  normalize aenv = aenv { aenvEqs   = {-notracepp-} mytracepp "aenvEqs"   (normalize <$> aenvEqs   aenv)-                        , aenvSimpl = {-notracepp-} mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) }--instance Normalizable Rewrite where-  normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw }-    where-      su  = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'-      xs  = smArgs rw-      xs' = zipWith mkSymbol xs [0 :: Integer ..]-      mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i--instance Normalizable Equation where-  normalize eq = eq {eqArgs = zip xs' ss,-                     eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq }-    where-      su           = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'-      (xs,ss)      = unzip (eqArgs eq)-      xs'          = zipWith mkSymbol xs [0 :: Integer ..]-      mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i--normalizeBody :: Symbol -> Expr -> Expr-normalizeBody f = go-  where-    go e-      | elem f (syms e)-      = go' e-    go e-      = e--    go' (PAnd [PImp c e1,PImp (PNot c') e2])-      | c == c' = EIte c e1 (go' e2)-    go' e = e
src/Language/Fixpoint/Solver/Monad.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}  -- | This is a wrapper around IO that permits SMT queries@@ -5,16 +6,18 @@ module Language.Fixpoint.Solver.Monad        ( -- * Type          SolveM-       , liftSMT           -- * Execution        , runSolverM -       , getContext+         -- * Get Binds+       , getBinds           -- * SMT Query        , filterRequired        , filterValid+       , filterValidGradual+       , checkSat        , smtEnablembqi        , sendConcreteBindingsToSMT @@ -24,12 +27,9 @@        , stats        , numIter        , SolverState(..)--       , modifyContext        )        where -import           Control.Monad (forM, forM_, when) import           Language.Fixpoint.Utils.Progress import qualified Language.Fixpoint.Types.Config  as C import           Language.Fixpoint.Types.Config  (Config)@@ -42,31 +42,29 @@ import           Language.Fixpoint.Smt.Serialize () import           Language.Fixpoint.Types.PrettyPrint () import           Language.Fixpoint.Smt.Interface-import           Language.Fixpoint.Smt.Types (SmtM) -- import qualified Language.Fixpoint.Smt.Theories as Thy import           Language.Fixpoint.Solver.Sanitize import           Language.Fixpoint.Solver.Stats import           Language.Fixpoint.Graph.Types (SolverInfo (..)) -- import           Language.Fixpoint.Solver.Solution -- import           Data.Maybe           (catMaybes)+import           Data.List            (partition) -- import           Data.Char            (isUpper)-import qualified Control.Monad.State as ST import           Control.Monad.State.Strict import qualified Data.HashMap.Strict as M import           Data.Maybe (catMaybes) import           Control.Exception.Base (bracket)-import Language.Fixpoint.SortCheck (ElabParam)  -------------------------------------------------------------------------------- -- | Solver Monadic API -------------------------------------------------------- -------------------------------------------------------------------------------- -type SolveM ann = StateT (SolverState ann) IO+type SolveM = StateT SolverState IO -data SolverState ann = SS-  { ssCtx     :: !Context         -- ^ SMT Solver Context-  , ssStats   :: !Stats           -- ^ Solver Statistics-  , ssElabParam :: !ElabParam      -- ^ Elaboration Parameters+data SolverState = SS +  { ssCtx     :: !Context          -- ^ SMT Solver Context+  , ssBinds   :: !F.BindEnv        -- ^ All variables and types+  , ssStats   :: !Stats            -- ^ Solver Statistics   }  stats0    :: F.GInfo c b -> Stats@@ -75,57 +73,57 @@     nCs   = M.size $ F.cm fi  ---------------------------------------------------------------------------------runSolverM :: Config -> SolverInfo ann -> ElabParam -> SolveM ann a -> IO a+runSolverM :: Config -> SolverInfo b c -> SolveM a -> IO a ---------------------------------------------------------------------------------runSolverM cfg sI elabParam act =+runSolverM cfg sI act =   bracket acquire release $ \ctx -> do     res <- runStateT act' (s0 ctx)+    smtExit ctx     return (fst res)   where-    s0 ctx   = SS ctx (stats0 fi) elabParam+    s0 ctx   = SS ctx be (stats0 fi)     act'     = assumesAxioms (F.asserts fi) >> act     release  = cleanupContext-    acquire  = makeContextWithSEnv cfg file initEnv (F.defns fi)-    initEnv  = symbolEnv cfg fi+    acquire  = makeContextWithSEnv cfg file initEnv+    initEnv  = symbolEnv   cfg fi+    be       = F.bs fi     file     = C.srcFile cfg-    -- only linear arithmetic when: linear flag is on or solver /= Z3+    -- only linear arithmentic when: linear flag is on or solver /= Z3     -- lar     = linear cfg || Z3 /= solver cfg-    fi       = (siQuery sI) {F.hoInfo = F.cfgHoInfo cfg }+    fi       = (siQuery sI) {F.hoInfo = F.HOI (C.allowHO cfg) (C.allowHOqs cfg)} + ---------------------------------------------------------------------------------getIter :: SolveM ann Int+getBinds :: SolveM F.BindEnv  --------------------------------------------------------------------------------+getBinds = ssBinds <$> get++--------------------------------------------------------------------------------+getIter :: SolveM Int+-------------------------------------------------------------------------------- getIter = numIter . ssStats <$> get  ---------------------------------------------------------------------------------incIter, incBrkt :: SolveM ann ()+incIter, incBrkt :: SolveM () -------------------------------------------------------------------------------- incIter   = modifyStats $ \s -> s {numIter = 1 + numIter s} incBrkt   = modifyStats $ \s -> s {numBrkt = 1 + numBrkt s}  ---------------------------------------------------------------------------------incChck, incVald :: Int -> SolveM ann ()+incChck, incVald :: Int -> SolveM () -------------------------------------------------------------------------------- incChck n = modifyStats $ \s -> s {numChck = n + numChck s} incVald n = modifyStats $ \s -> s {numVald = n + numVald s} -liftSMT :: SmtM a -> SolveM ann a-liftSMT k =-  do es <- get-     let ctx = ssCtx es-     (a, ctx') <- lift $ ST.runStateT k ctx-     put (es {ssCtx = ctx'})-     pure a+withContext :: (Context -> IO a) -> SolveM a+withContext k = (lift . k) =<< getContext -getContext :: SolveM ann Context+getContext :: SolveM Context getContext = ssCtx <$> get -modifyStats :: (Stats -> Stats) -> SolveM ann ()+modifyStats :: (Stats -> Stats) -> SolveM () modifyStats f = modify $ \s -> s { ssStats = f (ssStats s) } -modifyContext :: (Context -> Context) -> SolveM ann ()-modifyContext f = modify $ \s -> s { ssCtx = f (ssCtx s) }- -------------------------------------------------------------------------------- -- | SMT Interface ------------------------------------------------------------- --------------------------------------------------------------------------------@@ -135,26 +133,23 @@ -- -- Yields the ids of bindings known to the SMT sendConcreteBindingsToSMT-  :: F.IBindEnv -> F.BindEnv ann -> (F.IBindEnv -> SolveM ann a) -> SolveM ann a-sendConcreteBindingsToSMT known be act = do+  :: 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+        | (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'') <- liftSMT $-    smtBracket "sendConcreteBindingsToSMT" $ do+  (a, st') <- withContext $ \me -> do+    smtBracket me "" $ do       forM_ concretePreds $ \(i, e) ->-        smtDefineFunc (F.bindSymbol (fromIntegral i)) [] F.boolSort e-      ctx <- get-      let st' = st { ssCtx = ctx }-      (a, st'') <- liftIO $ flip runStateT st' $ act $ F.unionIBindEnv known $ F.fromListIBindEnv $ map fst concretePreds-      put (ssCtx st'')-      return (a, st'')-  modify $ \st''' -> st'' { ssCtx = ssCtx st''' }+        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@@ -164,20 +159,39 @@ -- | `filterRequired [(x1, p1),...,(xn, pn)] q` returns a minimal list [xi] s.t. --   /\ [pi] => q ---------------------------------------------------------------------------------filterRequired :: F.Cand a -> F.Expr -> SolveM ann [a]+filterRequired :: F.Cand a -> F.Expr -> SolveM [a] -------------------------------------------------------------------------------- filterRequired = error "TBD:filterRequired" +{-+(set-option :produce-unsat-cores true)+(declare-fun x () Int)+(declare-fun y () Int)+(declare-fun z () Int)++; Z3 will only track assertions that are named.++(assert (< 0 x))+(assert (! (< 0 y)       :named b2))+(assert (! (< x 10)      :named b3))+(assert (! (< y 10)      :named b4))+(assert (! (< (+ x y) 0) :named bR))+(check-sat)+(get-unsat-core)++> unsat (b2 bR)+-}+ ----------------------------------------------------------------------------------- | `filterValid p [(q1, x1),...,(qn, xn)]` returns the list `[ xi | p => qi]`+-- | `filterValid p [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]` -------------------------------------------------------------------------------- {-# SCC filterValid #-}-filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM ann [a]+filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM [a] -------------------------------------------------------------------------------- filterValid sp p qs = do-  qs' <- liftSMT $-           smtBracket "filterValidLHS" $-             filterValid_ sp p qs+  qs' <- withContext $ \me ->+           smtBracket me "filterValidLHS" $+             filterValid_ sp p qs me   -- stats   incBrkt   incChck (length qs)@@ -185,34 +199,80 @@   return qs'  {-# SCC filterValid_ #-}-filterValid_ :: F.SrcSpan -> F.Expr -> F.Cand a -> SmtM [a]-filterValid_ sp p qs = catMaybes <$> do-  smtAssertDecl p+filterValid_ :: F.SrcSpan -> F.Expr -> F.Cand a -> Context -> IO [a]+filterValid_ sp p qs me = catMaybes <$> do+  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+++--------------------------------------------------------------------------------+-- | `filterValidGradual ps [(x1, q1),...,(xn, qn)]` returns the list `[ xi | p => qi]`+-- | for some p in the list ps+--------------------------------------------------------------------------------+filterValidGradual :: [F.Expr] -> F.Cand a -> SolveM [a]+--------------------------------------------------------------------------------+filterValidGradual p qs = do+  qs' <- withContext $ \me ->+           smtBracket me "filterValidGradualLHS" $+             filterValidGradual_ p qs me+  -- stats+  incBrkt+  incChck (length qs)+  incVald (length qs')+  return qs'++filterValidGradual_ :: [F.Expr] -> F.Cand a -> Context -> IO [a]+filterValidGradual_ ps qs me+  = (map snd . fst) <$> foldM partitionCandidates ([], qs) ps+  where+    partitionCandidates :: (F.Cand a, F.Cand a) -> F.Expr -> IO (F.Cand a, F.Cand a)+    partitionCandidates (ok, candidates) p = do+      (valids', invalids')  <- partition snd <$> filterValidOne_ p candidates me+      let (valids, invalids) = (fst <$> valids', fst <$> invalids')+      return (ok ++ valids, invalids)++filterValidOne_ :: F.Expr -> F.Cand a -> Context -> IO [((F.Expr, a), Bool)]+filterValidOne_ p qs me = do+  smtAssert me p   forM qs $ \(q, x) ->-    smtBracketAt sp "filterValidRHS" $ do-      smtAssertDecl (F.PNot q)-      valid <- smtCheckUnsat-      return $ if valid then Just x else Nothing+    smtBracket me "filterValidRHS" $ do+      smtAssert me (F.PNot q)+      valid <- smtCheckUnsat me+      return $ ((q, x), valid) -smtEnablembqi :: SolveM ann ()+smtEnablembqi :: SolveM () smtEnablembqi-  = liftSMT smtSetMbqi+  = withContext smtSetMbqi  ---------------------------------------------------------------------------------assumesAxioms :: [F.Triggered F.Expr] -> SolveM ann ()+checkSat :: F.Expr -> SolveM  Bool ---------------------------------------------------------------------------------assumesAxioms es = liftSMT $ forM_ es smtAssertAxiom+checkSat p+  = withContext $ \me ->+      smtBracket me "checkSat" $+        smtCheckSat me p +--------------------------------------------------------------------------------+assumesAxioms :: [F.Triggered F.Expr] -> SolveM ()+--------------------------------------------------------------------------------+assumesAxioms es = withContext $ \me -> forM_  es $ smtAssertAxiom me + ----------------------------------------------------------------------------stats :: SolveM ann Stats+stats :: SolveM Stats --------------------------------------------------------------------------- stats = ssStats <$> get  ----------------------------------------------------------------------------tickIter :: Bool -> SolveM ann Int+tickIter :: Bool -> SolveM Int --------------------------------------------------------------------------- tickIter newScc = progIter newScc >> incIter >> getIter -progIter :: Bool -> SolveM ann ()+progIter :: Bool -> SolveM () progIter newScc = lift $ when newScc progressTick
src/Language/Fixpoint/Solver/PLE.hs view
@@ -1,1745 +1,1168 @@ ----------------------------------------------------------------------------------- | This module implements "Proof by Logical Evaluation" where we---   unfold function definitions if they *must* be unfolded, to strengthen---   the environments with function-definition-equalities.---   The algorithm is discussed at length in:------     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842---     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf-----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DoAndIfThenElse           #-}--module Language.Fixpoint.Solver.PLE-  ( instantiate--  -- The following exports are for property testing.-  , FuelCount(..)-  , ICtx(..)-  , Knowledge(..)-  , simplify-  )-  where--import           Language.Fixpoint.Types hiding (simplify)-import           Language.Fixpoint.Types.Config  as FC-import           Language.Fixpoint.Types.Solutions (CMap, Solution)-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.Smt.Types (SmtM)-import           Language.Fixpoint.Defunctionalize-import           Language.Fixpoint.Solver.EnvironmentReduction (inlineInExpr, undoANF)-import qualified Language.Fixpoint.Utils.Files   as Files-import qualified Language.Fixpoint.Utils.Trie    as T-import           Language.Fixpoint.Utils.Progress-import           Language.Fixpoint.SortCheck-import           Language.Fixpoint.Graph.Deps             (isTarget)-import           Language.Fixpoint.Solver.Common          (askSMT, toSMT)-import           Language.Fixpoint.Solver.Sanitize        (symbolEnv)-import           Language.Fixpoint.Solver.Simplify-import           Language.Fixpoint.Solver.Solution (CombinedEnv(..), applyInSortedReft)-import           Language.Fixpoint.Solver.Rewrite as Rewrite--import Language.REST.OCAlgebra as OC-import Language.REST.ExploredTerms as ExploredTerms-import Language.REST.RuntimeTerm as RT-import Language.REST.SMT (withZ3, SolverHandle)--import           Control.Monad (filterM, foldM, forM_, when, replicateM, zipWithM)-import           Control.Monad.State-import           Control.Monad.Trans.Maybe-import           Data.Bifunctor (second)-import qualified Data.HashMap.Strict  as M-import qualified Data.HashMap.Lazy  as HashMap.Lazy-import qualified Data.HashSet         as S-import           Data.IORef-import qualified Data.List            as L-import           Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Maybe           as Mb-import qualified Data.Set as Set-import           Text.PrettyPrint.HughesPJ.Compat--mytracepp :: (PPrint a) => String -> a -> a-mytracepp = notracepp------------------------------------------------------------------------------------- | Strengthen Constraint Environments via PLE------ @instantiate cfg fi subcIds@ yields @F.bs fi@ strengthened with the--- unfoldings discovered by PLE on the constraints in @subcIds@ (or all--- constraints if @subcIds == Nothing@).-{-# SCC instantiate #-}-instantiate :: (Loc a) => Config -> SInfo a -> Maybe Solution -> Maybe [SubcId] -> SmtM (BindEnv a)-instantiate cfg fi' mSol subcIds = do-    let cs = M.filterWithKey-               (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds)-               (cm info)-    let t  = mkCTrie (M.toList cs)                                          -- 1. BUILD the Trie-    res   <- withRESTSolver $ \solver -> do-               ctx <- get-               (res, ctx') <- liftIO $ withProgressM (`runStateT` ctx) (1 + M.size cs) $ do-                 env <- instEnv cfg info mSol cs solver-                 pleTrie t env                                              -- 2. TRAVERSE Trie to compute InstRes-               put ctx'-               return res-    liftIO $ savePLEEqualities cfg info sEnv res-    return $ resSInfo cfg sEnv info res                                     -- 3. STRENGTHEN SInfo using InstRes-  where-    withRESTSolver :: (Maybe SolverHandle -> SmtM a) -> SmtM a-    withRESTSolver f | all null (M.elems $ aenvAutoRW aEnv) = f Nothing-    withRESTSolver f = withZ3 (f . Just)--    sEnv = symbolEnv cfg info-    aEnv = ae info-    info = normalize fi'--savePLEEqualities :: Config -> SInfo a -> SymEnv -> InstRes -> IO ()-savePLEEqualities cfg info sEnv res = when (save cfg) $ do-    let fq   = queryFile Files.Fq cfg ++ ".ple"-    putStrLn $ "\nSaving PLE equalities: "   ++ fq ++ "\n"-    Misc.ensurePath fq-    let constraint_equalities =-          map equalitiesPerConstraint $ Misc.hashMapToAscList $ cm info-    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] ])-    elabParam = ElabParam (solverFlags cfg) "savePLEEqualities" sEnv-    renderConstraintRewrite (cid, eqs) =-      "constraint id" <+> text (show cid ++ ":")-      $+$ nest 2-           (vcat $ L.intersperse "" $-            map (toFix . unElab) $ Set.toList $ Set.fromList $-            -- call elabExpr to try to bring equations that are missing-            -- some casts into a fully annotated form for comparison-            map (elabExpr elabParam (Just boolSort)) $-            concatMap conjuncts eqs-           )-      $+$ ""------------------------------------------------------------------------------------ | Step 1a: @instEnv@ sets up the incremental-PLE environment-instEnv-  :: Loc a-  => Config-  -> SInfo a-  -> Maybe Solution-  -> CMap (SimpC a)-  -> Maybe SolverHandle-  -> SmtM (InstEnv a)-instEnv cfg info s cs restSolver = do-    ctx <- get-    refRESTCache <- liftIO $ newIORef mempty-    refRESTSatCache <- liftIO $ newIORef mempty-    let-        restOrd = FC.restOC cfg-        oc0 = ordConstraints restOrd $ Mb.fromJust restSolver-        oc :: OCAlgebra OCType RuntimeTerm IO-        oc = oc0-             { OC.isSat = cachedIsSat refRESTSatCache oc0-             , OC.notStrongerThan = cachedNotStrongerThan refRESTCache oc0-             }-        et :: ExploredTerms RuntimeTerm OCType IO-        et = ExploredTerms.empty-               EF-                 { ExploredTerms.union = OC.union oc-                 , ExploredTerms.subsumes = OC.notStrongerThan oc-                 , exRefine = OC.refine oc-                 }-                 ExploreWhenNeeded-        s0 = EvalEnv-              { evEnv = SMT.ctxSymEnv ctx-              , evElabF = ef-              , evKCtx = ctx-              , evExScope = []-              , evPendingUnfoldings = mempty-              , evNewEqualities = mempty-              , evSMTCache = mempty-              , evFuel = defFuelCount cfg-              , freshEtaNames = 0-              , explored = Just et-              , restSolver = restSolver-              , restOCA = restOrd-              , evOCAlgebra = oc-              }-    return $ InstEnv-       { ieCfg = cfg-       , ieBEnv = bs info-       , ieAenv = ae info-       , ieCstrs = cs-       , ieKnowl = knowledge cfg info-       , ieEvEnv = s0-       , ieLRWs  = lrws info-       , ieSol  = s-       }-  where-    ef = solverFlags cfg--    cachedNotStrongerThan refRESTCache oc a b = do-      m <- readIORef refRESTCache-      case M.lookup (a, b) m of-        Nothing -> do-          nst <- OC.notStrongerThan oc a b-          writeIORef refRESTCache (M.insert (a, b) nst m)-          return nst-        Just nst ->-          return nst--    cachedIsSat refRESTSatCache oc a = do-      m <- readIORef refRESTSatCache-      case M.lookup a m of-        Nothing -> do-          sat <- OC.isSat oc a-          writeIORef refRESTSatCache (M.insert a sat m)-          return sat-        Just sat ->-          return sat--------------------------------------------------------------------------------------------------- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments------ The trie is a way to unfold the equalities a minimum number of times.--- Say you have------ > 1: [1, 2, 3, 4, 5] => p1--- > 2: [1, 2, 3, 6, 7] => p2------ Then you build the tree------ >  1 -> 2 -> 3 -> 4 -> 5 — [Constraint 1]--- >            | -> 6 -> 7 — [Constraint 2]------ which you use to unfold everything in 1, 2, and 3 once (instead of twice)--- and with the proper existing environment----mkCTrie :: [(SubcId, SimpC a)] -> CTrie-mkCTrie ics  = T.fromList [ (cBinds c, i) | (i, c) <- ics ]-  where-    cBinds   = L.sort . elemsIBindEnv . senv--------------------------------------------------------------------------------------------------- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE-pleTrie :: Loc a => CTrie -> InstEnv a -> SmtM InstRes-pleTrie t env = loopT env ctx0 diff0 Nothing res0 t-  where-    diff0        = []-    res0         = M.empty-    ctx0         = ICtx-      { icAssms              = mempty-      , icCands              = mempty-      , icEquals             = mempty-      , icSimpl              = mempty-      , icSubcId             = Nothing-      , icANFs               = []-      , icLRWs               = mempty-      , icBindIds            = mempty-      , icEtaBetaFlag        = etabeta        $ ieCfg env-      , icExtensionalityFlag = extensionality $ ieCfg env-      , icLocalRewritesFlag  = localRewrites  $ ieCfg env-      , icFreshExistentialCounter = 0-      , icInitialLHSs  = mempty-      }--loopT-  :: Loc a-  => 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-  -> SmtM InstRes-loopT env ictx delta i res t = case t of-  T.Node []  -> return res-  T.Node [b] -> loopB env ictx delta i res b-  T.Node bs  -> withAssms env ictx delta Nothing (Just t) $ \ictx' -> do-                  (ictx'', env'', res') <- ple1 env ictx' i res-                  foldM (loopB env'' ictx'' [] i) res' bs--loopB-  :: Loc a-  => 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-  -> SmtM InstRes-loopB env ictx delta iMb res b = case b of-  T.Bind i t -> loopT env ictx (i:delta) (Just i) res t-  T.Val cid  -> withAssms env ictx delta (Just cid) Nothing $ \ictx' -> do-                  liftIO progressTick-                  (\(_, _, r) -> r) <$> ple1 env ictx' iMb res--collectConstraints :: CTrie -> [SubcId]-collectConstraints = go-  where-    go (T.Node bs) = concatMap goB bs-    goB (T.Bind _ t) = go t-    goB (T.Val cid)  = [cid]---- | Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@--- and the rhs of @cidMb@.------ Adds to @ctx@ assumptions from @env@ and @delta@.------ Sets the current constraint id in @ctx@ to @cidMb@.------ Pushes assumptions from the modified context to the SMT solver, runs @act@,--- and then pops the assumptions.----withAssms-  :: Loc a-  => InstEnv a-  -> ICtx-  -> Diff-  -> Maybe SubcId-  -> Maybe CTrie-  -> (ICtx -> SmtM b)-  -> SmtM b-withAssms env ctx delta cidMb mCTrie act = do-  sctx <- get-  let cfg = SMT.config sctx-  let (ictx', bs) = updCtx cfg env sctx ctx delta cidMb mCTrie-  let assms = icAssms ictx'--  SMT.smtBracket "PLE.withAssms" $ do-    -- See Note [Existential quantification when unfolding]-    SMT.smtDecls $ elabBindings (ieEvEnv env) bs-    forM_ (S.toList assms) SMT.smtAssertDecl-    act $ ictx' { icAssms = mempty }--  where-    elabBindings eenv bs =-      elaborate (ElabParam (evElabF eenv) "withAssms: PExist Args" (evEnv eenv)) bs---- | @ple1@ performs the PLE at a single "node" in the Trie------ It will generate equalities for all function invocations in the candidates--- in @ctx@ for which definitions are known. The function definitions are in--- @ieKnowl@.-ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> SmtM (ICtx, InstEnv a, InstRes)-ple1 ie@InstEnv{..} ictx i res = do-  ctx <- get-  (ictx', env) <- liftIO $ runStateT (evalCandsLoop ieCfg ictx ieKnowl) (ieEvEnv { evKCtx = ctx })-  put $ evKCtx env-  let pendings = collectPendingUnfoldings env (icSubcId ictx)-      newEqs =-        reconstructExistentials-          (M.intersectionWith S.union (icInitialLHSs ictx) $         -- add original predicates-           M.map (S.map equalitiesPred) $                            -- construct equalities-           M.unionWith S.union pendings $                            -- pending unfoldings if any-           M.unionWith S.difference (icEquals ictx') (icEquals ictx) -- new equalities only-          )-  return (ictx', ie { ieEvEnv = env }, updCtxRes res i newEqs)-  where-    -- Pending unfoldings (i.e. with undecided guards) are collected only-    -- when we reach a leaf in the Trie, and only if the user asked for them.-    collectPendingUnfoldings env (Just _) | pleUndecGuards ieCfg =-      M.map (S.fromList . M.toList) (evPendingUnfoldings env)-    collectPendingUnfoldings _ _ = mempty--evalToSMT :: String -> Config -> SMT.Context -> [(Symbol, Sort)] -> (Expr, Expr) -> Pred-evalToSMT msg cfg ctx bs (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx bs (EEq e1 e2)---- | Generate equalities for all function invocations in the candidates--- in @ctx@ for which definitions are known. The function definitions are in--- @ieKnowl@.------ In pseudocode:------ > do--- >     for every candidate--- >         discover equalities,--- >         unfold function invocations,--- >         update candidates with the unfolded expressions--- >     send newly discovered equalities to the SMT solver--- > until no new equalities are discovered--- >       or the environment becomes inconsistent----evalCandsLoop :: Config -> ICtx -> Knowledge -> EvalST ICtx-evalCandsLoop cfg ictx0 γ = go ictx0 0-  where-    go :: ICtx -> Int -> EvalST ICtx-    go ictx _ | all null (icCands ictx) = return ictx-    go ictx i = do-      inconsistentEnv <- testForInconsistentEnvironment-      if inconsistentEnv-        then return ictx-        else do liftSMT $ SMT.smtAssertDecl $ pAndNoDedup $ S.toList $ icAssms ictx-                let ictx' = ictx { icAssms = mempty }-                    (scopes, candSets) = unzip $ M.toList $ icCands ictx-                    cands = map S.toList candSets-                (candss, uss) <- unzip <$> zipWithM (evalCand ictx' i) scopes cands-                let noCandidateChanged = all and $ zipWith (zipWith eqCand) candss cands-                    unknownEqs = M.unionWith S.difference (M.fromList (zip scopes uss)) (icEquals ictx)-                if all null unknownEqs && noCandidateChanged then-                  return ictx-                else do-                  ctx' <- gets evKCtx-                  let eqsSMT =-                        S.unions $ M.elems $-                          M.mapWithKey-                            (\scope -> S.map $ evalToSMT "evalCandsLoop" cfg ctx' scope)-                            unknownEqs-                      ictx'' = ictx-                        { icEquals = M.unionWith S.union (icEquals ictx) unknownEqs-                        , icAssms  = S.filter (not . isTautoPred) eqsSMT-                        }-                  go (ictx'' { icCands = M.fromList $ zip scopes (map (S.fromList . concat) candss) }) (i + 1)--    testForInconsistentEnvironment :: EvalST Bool-    testForInconsistentEnvironment =-      knPredsEvalST γ PFalse--    eqCand [e0] e1 = e0 == e1-    eqCand _ _ = False--    evalCand :: ICtx -> Int -> ExScope -> [Expr] -> EvalST ([[Expr]], S.HashSet (Expr, Expr))-    evalCand ictx i scope es = withExScope scope $ mapM (evalOne γ ictx i) es >>= collectEqs--    collectEqs :: [[Expr]] -> EvalST ([[Expr]], S.HashSet (Expr, Expr))-    collectEqs es = do-      env <- get-      let newEqs = evNewEqualities env-      modify $ \st -> st { evNewEqualities = mempty }-      return (es, newEqs)--    withExScope :: ExScope -> EvalST a -> EvalST a-    withExScope s m = do-      env <- get-      put $ env { evExScope = s }-      r <- m-      modify $ \st -> st { evExScope = evExScope env }-      return r---------------------------------------------------------------------------------------------------- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo-------------------------------------------------------------------------------------------------resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> BindEnv a-resSInfo cfg env info res = strengthenBinds info res'-  where-    res'     = M.fromList $ zip is ps''-    ps''     = zipWith (\i -> elaborate (ElabParam (solverFlags cfg) (atLoc dummySpan ("PLE1 " ++ show i)) env)) is ps'-    ps'      = defuncAny cfg env ps-    (is, ps) = unzip (M.toList res)--------------------------------------------------------------------------------------------------- | @InstEnv@ has the global information needed to do PLE-------------------------------------------------------------------------------------------------data InstEnv a = InstEnv-  { ieCfg   :: !Config-  , ieBEnv  :: !(BindEnv a)-  , ieAenv  :: !AxiomEnv-  , ieCstrs :: !(CMap (SimpC a))-  , ieKnowl :: !Knowledge-  , ieEvEnv :: !EvalEnv-  , ieLRWs  :: LocalRewritesEnv-  , ieSol :: Maybe Solution-  }--------------------------------------------------------------------------------------------------- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE-------------------------------------------------------------------------------------------------data ICtx    = ICtx-  { icAssms              :: S.HashSet Pred           -- ^ Equalities converted to SMT format-  , icCands              :: M.HashMap ExScope (S.HashSet Expr)  -- ^ "Candidates" for unfolding-  , icEquals             :: M.HashMap ExScope EvEqualities      -- ^ Accumulated equalities-  , icSimpl              :: !ConstMap                -- ^ Map of expressions to constants-  , icSubcId             :: Maybe SubcId             -- ^ Current subconstraint ID-  , icANFs               :: [[(Symbol, SortedReft)]] -- Hopefully contain only ANF things-  , icLRWs               :: LocalRewrites            -- ^ Local rewrites-  , icBindIds            :: IBindEnv                 -- ^ Bind Ids in the current context-  , icEtaBetaFlag        :: Bool                     -- ^ True if the etabeta flag is turned on, needed-                                                     -- for the eta expansion reasoning as its going to-                                                     -- generate ho constraints-                                                     -- See Note [Eta expansion].-  , icExtensionalityFlag :: Bool                     -- ^ True if the extensionality flag is turned on-  , icLocalRewritesFlag  :: Bool                     -- ^ True if the local rewrites flag is turned on-  , icFreshExistentialCounter :: Int                 -- ^ Counter to generate fresh names for existentials-  , icInitialLHSs :: M.HashMap ExScope (S.HashSet Expr)-                                                     -- ^ LHS candidates before any unfoldings-  }--------------------------------------------------------------------------------------------------- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId-------------------------------------------------------------------------------------------------type InstRes = M.HashMap BindId Expr--------------------------------------------------------------------------------------------------- | @Unfold is the result of running PLE at a single equality;---     (e, [(e1, e1')...]) is the source @e@ and the (possible empty)---   list of PLE-generated equalities (e1, e1') ...-------------------------------------------------------------------------------------------------type CTrie   = T.Trie   SubcId-type CBranch = T.Branch SubcId-type Diff    = [BindId]    -- ^ in "reverse" order--equalitiesPred :: (Expr, Expr) -> Expr-equalitiesPred (e1, e2)-  | e1 /= e2 = EEq e1 e2-  | otherwise = PTrue--updCtxRes :: InstRes -> Maybe BindId -> [Expr] -> InstRes-updCtxRes res iMb = updRes res iMb . pAndNoDedup---updRes :: InstRes -> Maybe BindId -> Expr -> InstRes-updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res-updRes res  Nothing _ = res--------------------------------------------------------------------------------------------------- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@---   to the context.------ Yields the new context and a list of existential binders found in @delta@.--- See Note [Existential quantification when unfolding].-------------------------------------------------------------------------------------------------updCtx-  :: Loc a-  => Config-  -> InstEnv a-  -> SMT.Context-  -> ICtx-  -> Diff-  -> Maybe SubcId-  -> Maybe CTrie-  -> (ICtx, [(Symbol, Sort)])-updCtx cfg InstEnv{..} ieSMT ictx delta cidMb mCTrie =-    ( ictx { icAssms  = S.fromList ctxEqs-           , icCands  = M.unionWith S.union candsPerExScope (icCands ictx)-           , icSimpl  = icSimpl ictx <> econsts-           , icSubcId = cidMb-           , icANFs   = anfBinds-           , icLRWs   = mconcat $ icLRWs ictx : newLRWs-           , icBindIds = ibinds-           , icFreshExistentialCounter = existentialCounter-           , icInitialLHSs = M.unionWith S.union candsPerExScopeNoRHS (icInitialLHSs ictx)-           }-    , ebs-    )-  where-    ebs = concat (M.keys candsPerExScope)-    ibinds = insertsIBindEnv delta (icBindIds ictx)-    cands     = rhs:es-    anfBinds  = bs : icANFs ictx-    econsts   = M.fromList $ findConstants ieKnowl es-    ctxEqs    = toSMT "updCtx" ieCfg ieSMT ebs <$> L.nub-                  [ c-                  | (_, s) <- drop 1 deANFedCands-                  , e <- S.toList s-                  , c <- conjuncts e-                  , not (isTautoPred c)-                  ]-    bs        = second unApplySortedReft <$> binds-    rhs       = unApply eRhs-    es        = expr <$> bs-    eRhs      = maybe PTrue crhs subMb--    (binds, existentialCounter) = renameExistentialsInSortedRefts binds0 (icFreshExistentialCounter ictx)--    binds0    = [ maybeApplyKVarSolutions (x, y)-                | i <- delta-                , let (x, y, _) = lookupBindEnv i ieBEnv-                ]-    subMb     = getCstr ieCstrs <$> cidMb-    newLRWs   = Mb.mapMaybe (`lookupLocalRewrites` ieLRWs) delta--    candsPerExScopeNoRHS = M.fromListWith S.union $ ([], S.empty) : drop 1 deANFedCands-    -- ebs expects all keys to contain disjoint sets of bindings-    candsPerExScope = M.unionWith S.union candsPerExScopeNoRHS $ M.fromListWith S.union (take 1 deANFedCands)--    deANFedCands = map (second S.singleton . prenexExistentials) $-      -- We only call 'deANF' if necessary.-      if not (null (getAutoRws ieKnowl cidMb))-         || icExtensionalityFlag ictx-         || icEtaBetaFlag ictx then-        deANF anfBinds cands-      else-        cands--    maybeApplyKVarSolutions xsr =-      case ieSol of-        Just sol -> applyInSortedReft cfg g sol xsr-        Nothing  -> xsr-      where-        gCid = case collectConstraints <$> mCTrie of-          Just (c:_) -> Just c-          _ -> Nothing-        g = CEnv-          { ceCid = gCid-          , ceBEnv = ieBEnv-          , ceIEnv = ibinds-          , ceSpan = maybe dummySpan srcSpan $ gCid >>= (`M.lookup` ieCstrs)-          , ceBindingsInSmt = emptyIBindEnv-          }---findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]-findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)]-  where-    go su ess = if ess == ess'-                  then su-                  else go (su ++ su') ess'-       where ess' = subst (mkSubst su') <$> ess-             su'  = makeSu ess-    makeSu exprs  = [(x,c) | (EEq (EVar x) c) <- exprs-                           , isConstant (knDCs γ) c-                           , EVar x /= c ]--getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a-getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env--isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool-isPleCstr aenv subid c = isTarget c && M.lookupDefault False subid (aenvExpand aenv)--type EvEqualities = S.HashSet (Expr, Expr)-----------------------------------------------------------------------------------data EvalEnv = EvalEnv-  { evEnv      :: !SymEnv-  , evElabF    :: ElabFlags-  , evKCtx     :: SMT.Context-    -- | The current scope of existential variables.-    -- See Note [Existential quantification when unfolding].-  , evExScope  :: ExScope-    -- | Equalities where we couldn't evaluate the guards, in a map which-    -- uses their existential scope as key.-    ---    -- See Note [Existential quantification when unfolding].-  , evPendingUnfoldings :: M.HashMap ExScope (M.HashMap Expr Expr)-  , evNewEqualities :: EvEqualities -- ^ Equalities discovered during a traversal of-                                    -- an expression-  , evSMTCache :: M.HashMap Expr Bool -- ^ Whether an expression is valid or its negation-  , evFuel     :: FuelCount--  -- Eta expansion feature-  , freshEtaNames :: Int -- ^ Keeps track of how many names we generated to perform eta-                         --   expansion, we use this to generate always fresh names-  -- REST parameters-  , explored   :: Maybe (ExploredTerms RuntimeTerm OCType IO)-  , restSolver :: Maybe SolverHandle-  , restOCA    :: RESTOrdering-  , evOCAlgebra :: OCAlgebra OCType RuntimeTerm IO-  }--data FuelCount = FC-  { fcMap :: M.HashMap Symbol Int-  , fcMax :: Maybe Int-  }-  deriving (Show)--defFuelCount :: Config -> FuelCount-defFuelCount cfg = FC mempty (fuel cfg)--type EvalST a = StateT EvalEnv IO a--liftSMT :: SmtM a -> EvalST a-liftSMT k =-  do es <- get-     let ctx = evKCtx es-     (a, ctx') <- lift $ runStateT k ctx-     put (es {evKCtx = ctx'})-     pure a------------------------------------------------------------------------------------getAutoRws :: Knowledge -> Maybe SubcId -> [AutoRewrite]-getAutoRws γ mSubcId =-  Mb.fromMaybe [] $ do-    cid <- mSubcId-    M.lookup cid $ knAutoRWs γ---- | Discover the equalities in an expression.------ The discovered equalities are in the environment of the monad,--- and the list of produced expressions contains the result of unfolding--- definitions. When REST is in effect, more than one expression might--- be returned because expressions can then be rewritten in more than one--- way.-evalOne :: Knowledge -> ICtx -> Int -> Expr -> EvalST [Expr]-evalOne γ ctx i e-  | i > 0 || null (getAutoRws γ (icSubcId ctx)) = (:[]) <$> eval γ ctx NoRW e-evalOne γ ctx _ e | isExprRewritable e = do-    env <- get-    let oc :: OCAlgebra OCType RuntimeTerm IO-        oc = evOCAlgebra env-        rp = RP (contramap Rewrite.convert oc) [(e, PLE)] constraints-        constraints = OC.top oc-        emptyET = ExploredTerms.empty (EF (OC.union oc) (OC.notStrongerThan oc) (OC.refine oc)) ExploreWhenNeeded-    es <- evalREST γ ctx rp-    modify $ \st -> st { explored = Just emptyET }-    return es-evalOne _ _ _ _ = return []---- The FuncNormal and RWNormal evaluation strategies are used for REST--- For example, consider the following function:---   add(x, y) = if x == 0 then y else add(x - 1, y + 1)--- And a rewrite rule:---   forall a, b . add(a,b) -> add(b, a)--- Then the expression add(t, add(2, 1)) would evaluate under NoRW to:---   if t == 0 then 3 else add(t - 1, 4)--- However, under FuncNormal, it would evaluate to: add(t, 3)--- Thus, FuncNormal could engage the rewrite rule add(t, 3) = add(3, t)---data EvalType =-    NoRW       -- Normal PLE-  | NoRWEta    -- Like Normal PLE but we keep track that we are in an eta-               -- expansion context-  | 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)----- | Unfolds function invocations in expressions.------ Also reduces if-then-else when the boolean condition or the negation can be--- proved valid. This is the actual implementation of guard-validation-before-unfolding--- that is described in publications.------ Also adds to the monad state all the unfolding equalities that have been--- discovered as necessary.-eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST Expr-eval γ ctx et = go-  where-    go (ELam (x,s) e)   = evalELam γ ctx et (x, s) e-    go e@EIte{}         = evalIte γ ctx et e-    go (ECoerc s t e)   = ECoerc s t <$> go e-    go e@(EApp _ _)     =-      case splitEAppThroughECst e of-       (f, es) | et == RWNormal ->-          -- Just evaluate the arguments first, to give rewriting a chance to step in-          -- if necessary-          do-            es' <- mapM (eval γ ctx et) es-            if es /= es'-              then return (eApps f es')-              else do-                f' <- case dropECst f of-                  EVar _ -> pure f-                  _      -> go f-                Mb.fromMaybe (eApps f' es') <$> evalApp γ ctx f' es et-       (f, es) ->-          do-            f' <- case dropECst f of-              EVar _ -> pure f-              _      -> go f-            es' <- mapM (eval γ ctx et) es-            Mb.fromMaybe (eApps f' es') <$> evalApp γ ctx f' es' et--    go (PAtom r e1 e2) = PAtom r <$> go e1 <*> go e2-    go (ENeg e)         = ENeg <$> go e-    go (EBin o e1 e2)   = EBin o <$> go e1 <*> go e2-    go (ETApp e t)      = (`ETApp` t) <$> go e-    go (ETAbs e s)      = (`ETAbs` s) <$> go e-    go (PNot e')        = PNot <$> go e'-    go (PImp e1 e2)     = PImp <$> go e1 <*> go e2-    go (PIff e1 e2)     = PIff <$> go e1 <*> go e2-    go (PAnd es)        = PAnd <$> traverse go es-    go (POr es)         = POr <$> traverse go es-    go e | EVar _ <- dropECst e = do-      Mb.fromMaybe e <$> evalApp γ ctx e [] et-    go (ECst e t)       = (`ECst` t) <$> go e-    go (ELet x e1 e2)   = ELet x <$> go e1 <*> go e2--    go e                = return e----- | 'evalELam' produces equations that preserve the context of a rewrite--- so equations include any necessary lambda bindings.-evalELam :: Knowledge -> ICtx -> EvalType -> (Symbol, Sort) -> Expr -> EvalST Expr-evalELam γ ctx et (x, s) e-  | not $ isEtaSymbol x = do-    -- We need to refresh it as for some reason names bound by lambdas-    -- present in the source code are getting declared twice.-    -- Maybe we should define a new type of identifier for this kind of fresh-    -- variables and not reuse the etabeta ones.-    [ xFresh ] <- makeFreshEtaNames 1-    let newBody = subst (mkSubst [(x, EVar xFresh)]) e--    modify $ \st -> st-      { evNewEqualities-        = S.insert (ELam (x, s) e, ELam (xFresh, s) newBody)-                   (evNewEqualities st)-      }--    evalELam γ ctx et (xFresh, s) newBody-  where-    isEtaSymbol :: Symbol -> Bool-    isEtaSymbol = isPrefixOfSym "eta"--evalELam γ ctx et (x, s) e = do-  e' <- evalInExtendedEnv [(x, s)] γ ctx et e-  let elam = ELam (x, s) e-  modify $ \st -> st-    { evNewEqualities = S.insert (elam, ELam (x, s) e') (evNewEqualities st) }-  return (ELam (x, s) e')--evalInExtendedEnv :: [(Symbol, Sort)] -> Knowledge -> ICtx -> EvalType -> Expr -> EvalST Expr-evalInExtendedEnv binds γ ctx et e = do-  oldPendingUnfoldings <- gets evPendingUnfoldings-  oldEqs               <- gets evNewEqualities-  -- We need to declare the variables in the environment-  modify $ \st -> st-    { evEnv = insertsSymEnv (evEnv st) binds }-  e' <- eval (γ { knLams = binds ++ knLams γ }) ctx et e-  let e'' = simplify γ ctx e'-  -- Discard the old equalities which miss the lambda binding-  modify $ \st -> st-    { evPendingUnfoldings = oldPendingUnfoldings-    , evNewEqualities = oldEqs-    -- Leaving the scope thus we need to get rid of it-    , evEnv = deletesSymEnv (evEnv st) (map fst binds)-    }-  pure e''---data RESTParams oc = RP-  { oc   :: OCAlgebra oc Expr IO-  , path :: [(Expr, TermOrigin)]-  , c    :: oc-  }---- An expression is rewritable if it is in the domain of--- Language.Fixpoint.Solver.Rewrite.convert-isExprRewritable :: Expr -> Bool-isExprRewritable (EIte i t e ) = isExprRewritable i && isExprRewritable t && isExprRewritable e-isExprRewritable (EApp f e) = isExprRewritable f && isExprRewritable e-isExprRewritable (EVar _) = True-isExprRewritable (PNot e) = isExprRewritable e-isExprRewritable (PAnd es) = all isExprRewritable es-isExprRewritable (POr es) = all isExprRewritable es-isExprRewritable (PAtom _ l r) = isExprRewritable l && isExprRewritable r-isExprRewritable (EBin _ l r) = isExprRewritable l && isExprRewritable r-isExprRewritable (ECon _) = True-isExprRewritable (ESym _) = True-isExprRewritable (ECst _ _) = True-isExprRewritable (PIff e0 e1) = isExprRewritable (PAtom Eq e0 e1)-isExprRewritable (PImp e0 e1) = isExprRewritable (POr [PNot e0, e1])-isExprRewritable _ = False---- | Reverse the ANF transformation------ This is necessary for REST rewrites, beta reduction, and PLE to discover--- redexes.------ In the case of REST, ANF bindings could hide compositions that are--- rewriteable. For instance,------ > let anf1 = map g x--- >  in map f anf1------ could miss a rewrite like @map f (map g x) ~> map (f . g) x@.------ Similarly, ANF bindings could miss beta reductions. For instance,------ > let anf1 = \a b -> b--- >  in anf1 x y------ could only be reduced by PLE if @anf1@ is inlined.------ Lastly, in the following example PLE cannot unfold @reflectedFun@ unless the--- ANF binding is inlined.------ > f g = g 0--- > reflectedFun x y = if y == 0 then x else y--- >--- > let anf2 = (\eta1 -> reflectedFun x eta1)--- >  in f anf2------ unfolding @f@------ > let anf2 = (\eta1 -> reflectedFun x eta1)--- >  in anf2 0----deANF :: [[(Symbol, SortedReft)]] -> [Expr] -> [Expr]-deANF binds = map $ inlineInExpr (`HashMap.Lazy.lookup` bindEnv)-  where-    bindEnv = undoANF id-        $ HashMap.Lazy.filterWithKey (\sym _ -> anfPrefix `isPrefixOfSym` sym)-        $ HashMap.Lazy.unions $ map HashMap.Lazy.fromList binds---- |--- Adds to the monad state all the subexpressions that have been rewritten--- as pairs @(original_subexpression, rewritten_subexpression)@.------ Also folds constants.------ The main difference with 'eval' is that 'evalREST' takes into account--- autorewrites.----evalREST :: Knowledge -> ICtx -> RESTParams OCType -> EvalST [Expr]-evalREST γ ctx rp = do-  env <- get-  cacheRef <- liftIO $ newIORef $ evSMTCache env-  evalRESTWithCache cacheRef γ ctx [] rp--evalRESTWithCache-  :: IORef (M.HashMap Expr Bool) -> Knowledge -> ICtx -> [Expr] -> RESTParams OCType -> EvalST [Expr]-evalRESTWithCache cacheRef _ ctx acc rp-  | pathExprs <- map fst (mytracepp "EVAL1: path" $ path rp)-  , e         <- last pathExprs-  , Just v    <- M.lookup e (icSimpl ctx)-  = do-    smtCache <- liftIO $ readIORef cacheRef-    when (v /= e) $ modify (\st -> st-      { evNewEqualities = S.insert (e, v) (evNewEqualities st)-      , evSMTCache = smtCache-      })-    return (v : acc)--evalRESTWithCache cacheRef γ ctx acc rp =-  do-    mexploredTerms <- gets explored-    ebs <- gets evExScope-    case mexploredTerms of-      Nothing -> return acc-      Just exploredTerms -> do-        se <- liftIO (shouldExploreTerm ebs exploredTerms exprs)-        if se then do-          possibleRWs <- liftSMT (getRWs ebs)-          rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed ebs) possibleRWs-          oldEqualities <- gets evNewEqualities-          modify $ \st -> st { evNewEqualities = mempty }--          -- liftIO $ putStrLn $ (show $ length possibleRWs) ++ " rewrites allowed at path length " ++ (show $ (map snd $ path rp))-          e' <- do-            ec <- eval γ ctx FuncNormal exprs-            if ec /= exprs-              then return ec-              else eval γ ctx RWNormal exprs--          let evalIsNewExpr = e' `L.notElem` pathExprs-          let exprsToAdd    = [e' | evalIsNewExpr]  ++ map (\(_, e, _) -> e) rws-              acc' = exprsToAdd ++ acc-              eqnToAdd = [ (e1, simplify γ ctx e2) | ((e1, e2), _, _) <- rws ]--          let explored' st =-                if isExprRewritable e' && isExprRewritable exprs-                  then Just $ ExploredTerms.insert (Rewrite.convert exprs) (c rp)-                                                  (S.insert (Rewrite.convert e')-                            $ S.fromList (map (Rewrite.convert . (\(_, e, _) -> e)) possibleRWs))-                                        (Mb.fromJust $ explored st)-                  else Nothing--          newEqualities <- gets evNewEqualities-          smtCache <- liftIO $ readIORef cacheRef-          modify $ \st -> st-            { evNewEqualities  = foldr S.insert (S.union newEqualities oldEqualities) eqnToAdd-            , evSMTCache = smtCache-            , explored = explored' st-            }--          acc'' <- if evalIsNewExpr-            then if e' /= exprs && any isRW (path rp)-              then (:[]) <$> eval γ (addConst (exprs, e')) NoRW e'-              else evalRESTWithCache cacheRef γ (addConst (exprs, e')) acc' (rpEval newEqualities e')-            else return acc'--          foldM (\r rw -> evalRESTWithCache cacheRef γ ctx r (rpRW rw)) acc'' rws-        else-          return acc-  where-    shouldExploreTerm ebs exploredTerms e | Vis.isConc e =-      case rwTerminationOpts (rwArgs ebs) of-        RWTerminationCheckDisabled ->-          return $ not $ ExploredTerms.visited (Rewrite.convert e) exploredTerms-        RWTerminationCheckEnabled  ->-          ExploredTerms.shouldExplore (Rewrite.convert e) (c rp) exploredTerms-    shouldExploreTerm _ _ _ = return False--    allowed _ebs (_, rwE, _) | rwE `elem` pathExprs = return False-    allowed ebs (_, _, c)   = termCheck ebs c-    termCheck ebs c = Rewrite.passesTerminationCheck (oc rp) (rwArgs ebs) c--    notVisitedFirst exploredTerms rws =-      let-        (v, nv) = L.partition (\(_, e, _) -> ExploredTerms.visited (Rewrite.convert e) exploredTerms) rws-      in-        nv ++ v--    rpEval newEqualities e' =-      let-        c' =-          if any isRW (path rp)-            then foldr (\(e1, e2) ctrs -> refine (oc rp) ctrs e1 e2) (c rp) (S.toList newEqualities)-            else c rp--      in-        rp{path = path rp ++ [(e', PLE)], c = c'}--    isRW (_, r) = r == RW--    rpRW (_, e', c') = rp{path = path rp ++ [(e', RW)], c = c' }--    pathExprs       = map fst (mytracepp "EVAL2: path" $ path rp)-    exprs           = last pathExprs-    autorws         = getAutoRws γ (icSubcId ctx)--    rwArgs ebs = RWArgs (isValid cacheRef ebs γ) $ knRWTerminationOpts γ--    getRWs ebs =-      do-        -- Optimization: If we got here via rewriting, then the current constraints-        -- are satisfiable; otherwise double-check that rewriting is still allowed-        ok <--          if isRW $ last (path rp)-            then return True-            else liftIO $ termCheck ebs (c rp)-        if ok-          then-            do-              let getRW e ar = Rewrite.getRewrite (oc rp) (rwArgs ebs) (c rp) e ar-              let getRWs' s  = Mb.catMaybes <$> mapM (runMaybeT . getRW s) autorws-              concat <$> mapM getRWs' (subExprs exprs)-          else return []--    addConst (e,e') = if isConstant (knDCs γ) e'-                      then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx---- Note [Eta expansion]--- ~~~~~~~~~~~~~~~~~~~~------ Without eta expansion PLE could not prove that terms @f@ and @(\x -> f x)@--- have the same meaning. But sometimes we want to rewrite @f@ into the--- expanded form, in order to unfold @f@.------ For instance, suppose we have a function @const@ defined as:------ > define f (x : int, y : int) : int = {(x)}------ And we need to prove some constraint of this shape------ > { const a = \x:Int -> a }------ At first, PLE cannot unfold @const@ since it is not fully applied.--- But if instead perform eta expansion on the left hand side we obtain the--- following equality------ > { \y:Int -> const a y = \x:Int -> a}------ And now PLE can unfold @const@ as the application is saturated------ > { \y:Int -> a = \x:Int -> a}------ We need the higerorder flag active as we are generating lambdas in--- the equalities.----- Note [Elaboration for eta expansion]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Eta expansion needs to determine the arity and the type of arguments of a--- function. For this sake, we make sure that when unfolding introduces new--- expressions, these expressions get annotated with their types by calling--- @elaborateExpr@.------ This elaboration cannot be done ahead of time on equations, because then--- type variables are instantiated to rigid constants that cannot be unified.--- For instance, @id :: forall a. a -> a@ would be elaborated to--- @id :: a#1 -> a#1@, and when used in an expression like @id True@, @a#1@--- would not unify with @Bool@.----- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites--- and equations-evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Maybe Expr)-evalApp γ ctx e0 es et-  | EVar f <- dropECst e0-  , Just eq <- Map.lookup f (knAms γ)-  , length (eqArgs eq) <= length es-  = do-       env <- gets (seSort . evEnv)-       okFuel <- checkFuel f-       if okFuel && et /= FuncNormal then do-         let (es1, es2) = splitAt (length (eqArgs eq)) es-         -- See Note [Elaboration for eta expansion].-         let newE = substEq env eq es1-         newE' <- if icEtaBetaFlag ctx-                    then elaborateExpr "EvalApp unfold full: " newE-                    else pure newE--         e' <- evalIte γ ctx et newE'        -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter-         let e2' = stripPLEUnfold e'-         let e3' = simplify γ ctx (eApps e2' es2)  -- reduces a bit the equations--         if hasUndecidedGuard e' && guardOf e' == guardOf newE' && et /= NoRWEta then do-           -- Don't unfold the expression if there is an if-then-else guarding-           -- it, just to preserve the size of further rewrites.-           -- If evalIte does any modifications, though, we do unfold in order-           -- to allow analysis of the resulting expression-           -- Note(Alessio): this optimization make sense only if the-           -- function is already fully applied in the original-           -- program and not because of eta expansion, otherwise we might-           -- miss redexes. See https://github.com/ucsd-progsys/liquidhaskell/issues/2652-           modify $ \st -> st-             { evPendingUnfoldings =-                 M.insertWith M.union (evExScope st) (M.singleton (eApps e0 es) e3') (evPendingUnfoldings st)-             }-           return Nothing-         else do-           useFuel f-           modify $ \st -> st-             { evNewEqualities = S.insert (eApps e0 es, e3') (evNewEqualities st)-             , evPendingUnfoldings = M.adjust (M.delete (eApps e0 es)) (evExScope st) (evPendingUnfoldings st)-             }-           return (Just $ eApps e2' es2)-       else return Nothing-  where-    -- At the time of writing, any function application wrapping an-    -- if-statement would have the effect of unfolding the invocation.-    -- However, using pleUnfold still has the advantage of not generating-    -- extra equations to unfold pleUnfold itself. Using pleUnfold also-    -- makes the intention of the user rather explicit.-    stripPLEUnfold e-      | (ef, [arg]) <- splitEAppThroughECst e-      , EVar f <- dropECst ef-      , f == "Language.Haskell.Liquid.ProofCombinators.pleUnfold"-      = arg-      | otherwise = e--    hasUndecidedGuard EIte{} = True-    hasUndecidedGuard _ = False--    guardOf (EIte g _ _) = Just g-    guardOf _ = Nothing--evalApp γ ctx e0 args@(e:es) _-  | EVar f <- dropECst e0-  , (d, as) <- splitEAppThroughECst e-  , EVar dc <- dropECst d-  , Just rws <- Map.lookup dc (knSims γ)-    -- User data measures aren't sent to the SMT solver because-    -- it knows already about selectors and constructor tests.-  , Just (rw, isUserDataSMeasure) <- L.find (\(rw, _) -> smName rw == f) rws-  , length as == length (smArgs rw)-  = do-    let newE = eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es-    when (isUserDataSMeasure == NoUserDataSMeasure) $-      modify $ \st -> st-        { evNewEqualities = S.insert (eApps e0 args, simplify γ ctx newE) (evNewEqualities st) }-    return (Just newE)--evalApp γ ctx e0 es _et-  | eqs@(_:_) <- noUserDataMeasureEqs γ (eApps e0 es)-  = do-       env <- gets (seSort . evEnv)-       -- Only well-sorted LHSs should be considered. For instance, a measure-       -- expecting an argument of type [[Int]] should not be applied to a value-       -- of type [Int].-       let eqs' = map (second $ simplify γ ctx) $-                    filter (wellSorted env . fst) eqs-       if null eqs' then return Nothing-       else do-         modify $ \st ->-           st { evNewEqualities = foldr S.insert (evNewEqualities st) eqs' }-         return Nothing--evalApp γ ctx e0 es et-  | ELam (argName, _) body <- dropECst e0-  , lambdaArg:remArgs <- es-  , icEtaBetaFlag ctx || icExtensionalityFlag ctx-  = do-      isFuelOk <- checkFuel argName-      if isFuelOk-        then do-          useFuel argName-          let argSubst = mkSubst [(argName, lambdaArg)]-          let body' = subst argSubst body-          body'' <- evalIte γ ctx et body'-          let simpBody = simplify γ ctx (eApps body'' remArgs)-          modify $ \st ->-            st { evNewEqualities = S.insert (eApps e0 es, simpBody) (evNewEqualities st) }-          return (Just $ eApps body'' remArgs)-        else do-          return Nothing--evalApp _ ctx e0 es _-  | icLocalRewritesFlag ctx-  , EVar f <- dropECst e0-  , Just rw <- lookupRewrite f $ icLRWs ctx-  = do-      -- expandedTerm <- elaborateExpr "EvalApp rewrite local:" $ eApps rw es-      let expandedTerm = eApps rw es-      modify $ \st -> st-        { evNewEqualities = S.insert (eApps e0 es, expandedTerm) (evNewEqualities st) }-      return (Just expandedTerm)--evalApp γ ctx e0 es _et-  -- We check the annotation instead of the equations in γ for two reasons.-  ---  -- First, we want to eta expand functions that might not be reflected. Suppose-  -- we have an uninterpreted function @f@, and we want to prove that-  -- @f == \a -> f a@. We can use eta expansion on the left-hand side to prove-  -- this.-  ---  -- Second, we need the type of the new arguments, which for some reason are-  -- sometimes instantiated in the equations to rigid types that we cannot-  -- instantiate to the types needed at the call site.-  -- See Note [Elaboration for eta expansion].-  ---  -- See Note [Eta expansion].-  ---  | ECst (EVar _f) sortAnnotation@FFunc{} <- e0-  , icEtaBetaFlag ctx-  , let expectedArgs = unpackFFuncs sortAnnotation-  , let nProvidedArgs = length es-  , let nArgsMissing = length expectedArgs - nProvidedArgs-  , nArgsMissing > 0-  = do-    let etaArgsType = drop nProvidedArgs expectedArgs-    -- Fresh names for the eta expansion-    etaNames <- makeFreshEtaNames nArgsMissing--    let etaVars = zipWith (\name ty -> ECst (EVar name) ty) etaNames etaArgsType-    let fullBody = eApps e0 (es ++ etaVars)-    let etaExpandedTerm = mkLams fullBody (zip etaNames etaArgsType)--    -- Note: we should always add the equality as etaNames is always non empty because the-    -- only way for etaNames to be empty is if the function is fully applied, but that case-    -- is already handled by the previous case of evalApp-    modify $ \st -> st-      { evNewEqualities = S.insert (eApps e0 es, etaExpandedTerm) (evNewEqualities st) }--    -- We also try to unfold the definition of the function in the eta-    -- expanded body, as it might give us more information to generate-    -- better equalities. Note that we pass NoRWEta to skip the optimization-    redBody <- evalInExtendedEnv (zip etaNames etaArgsType) γ ctx NoRWEta fullBody-    let etaExpandedRedBody = mkLams redBody (zip etaNames etaArgsType)-    modify $ \st -> st-      { evNewEqualities = S.insert (eApps e0 es, etaExpandedRedBody) (evNewEqualities st) }--    return (Just etaExpandedTerm)-  where-    unpackFFuncs (FFunc t ts) = t : unpackFFuncs ts-    unpackFFuncs _ = []--    mkLams subject binds = foldr ELam subject binds--evalApp _ _ctx _e0 _es _ = do-  return Nothing---- | Evaluates if-then-else statements until they can't be evaluated anymore--- or some other expression is found.-evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST Expr-evalIte γ ctx et (ECst e t) = do-  (`ECst` t) <$> evalIte γ ctx et e-evalIte γ ctx et (EIte i e1 e2) = do-      b <- eval γ ctx et i-      b'  <- mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValidCached γ b-      case b' of-        Just True -> evalIte γ ctx et e1-        Just False -> evalIte γ ctx et e2-        _ -> return (EIte b e1 e2)-evalIte _ _ _ e' = return e'---- | Creates equations that explain how to rewrite a given constructor--- application with all measures that aren't user data measures-noUserDataMeasureEqs :: Knowledge -> Expr -> [(Expr,Expr)]-noUserDataMeasureEqs γ e =-  [ (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw))-  | (ef, es) <- [splitEAppThroughECst e]-  , EVar f <- [dropECst ef]-  , Just rws <- [Map.lookup f (knSims γ)]-  , (rw, NoUserDataSMeasure) <- rws-  , length es == length (smArgs rw)-  ]---- | Check that an expression is well-sorted-wellSorted :: SEnv Sort -> Expr -> Bool-wellSorted env = Mb.isJust . checkSortExpr dummySpan env------------------------------------------------------------------------------------- | 'substEq' unfolds or instantiates an equation at a particular list of---   argument values. We must also substitute the sort-variables that appear---   as coercions. See tests/proof/ple1.fq----------------------------------------------------------------------------------substEq :: SEnv Sort -> Equation -> [Expr] -> Expr-substEq env eq es = subst su (substEqCoerce env eq es)-  where su = mkSubst $ zip (eqArgNames eq) es--substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr-substEqCoerce env eq es = Vis.applyCoSubV coSub $ eqBody eq-  where-    ts    = snd    <$> eqArgs eq-    sp    = panicSpan "mkCoSub"-    eTs   = sortExpr sp env <$> es-    coSub = mkCoSub env eTs ts---- | @mkCoSub senv eTs xTs = su@ creates a substitution @su@ such that--- @subst su xTs == eTs@.------ The variables in the domain of the substitution are those that appear--- as @FObj symbol@ in @xTs@.-mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSubV-mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ]-  where-    unite ts    = Mb.fromMaybe (uError ts) (unifyTo1 symToSearch ts)-    symToSearch = mkSearchEnv env-    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts)-    xys :: [(Sort, Sort)]-    xys         = Misc.sortNub $ concat $ zipWith matchSorts xTs eTs--matchSorts :: Sort -> Sort -> [(Sort, Sort)]-matchSorts = go-  where-    go x@(FObj _)    {-FObj-} y    = [(x, y)]-    go x@(FVar _)    {-FObj-} y    = [(x, y)]-    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2-    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2-    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2-    go _             _             = []------------------------------------------------------------------------------------eqArgNames :: Equation -> [Symbol]-eqArgNames = map fst . eqArgs--isValidCached :: Knowledge -> Expr -> EvalST (Maybe Bool)-isValidCached γ e = do-  env <- get-  case M.lookup e (evSMTCache env) of-    Nothing -> do-      let isFreeInE (s, _) = not (S.member s (exprSymbolsSet e))-      b <- knPredsEvalST γ e-      if b-        then do-          when (all isFreeInE (knLams γ)) $-            put (env { evSMTCache = M.insert e True (evSMTCache env) })-          return (Just True)-        else do-          b2 <- knPredsEvalST γ (PNot e)-          if b2-            then do-              when (all isFreeInE (knLams γ)) $-                put (env { evSMTCache = M.insert e False (evSMTCache env) })-              return (Just False)-            else-              return Nothing--    mb -> return mb------------------------------------------------------------------------------------- | Knowledge (SMT Interaction)----------------------------------------------------------------------------------data Knowledge = KN-  { -- | Rewrites rules came from match definitions-    ---    -- They are grouped by the data constructor that they unfold, and are-    -- augmented with an attribute that say whether they originate from a-    -- user data declaration.-    knSims              :: Map Symbol [(Rewrite, IsUserDataSMeasure)]-  , knAms               :: Map Symbol Equation -- ^ All function definitions-    -- | @knPreds γ bsInSMT xs e@ checks whether @e@ is valid under the-    -- assumptions that all variables in @bsInSMT@ are in the SMT solver,-    -- and that all variables in @xs@ need tp be declared in the SMT solver.-  , knPreds             :: [(Symbol, Sort)] -> [(Symbol, Sort)] -> Expr -> SmtM Bool-  , knLams              :: ![(Symbol, Sort)]-  , knSummary           :: ![(Symbol, Int)]     -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity-  , knDCs               :: !(S.HashSet Symbol)  -- ^ data constructors drawn from Rewrite-  , knDataCtors         :: !(M.HashMap Symbol DataCtor) -- ^ data constructors by name-  , knSels              :: !SelectorMap-  , knConsts            :: !ConstDCMap-  , knAutoRWs           :: M.HashMap SubcId [AutoRewrite]-  , knRWTerminationOpts :: RWTerminationOpts-  }---- | A type to express whether SMeasures originate from data definitions.--- That is whether they are constructor tests, selectors, or something else.-data IsUserDataSMeasure = NoUserDataSMeasure | UserDataSMeasure-  deriving (Eq, Show)--knPredsEvalST :: Knowledge -> Expr -> EvalST Bool-knPredsEvalST γ e = do-    env <- get-    liftSMT $ knPreds γ (evExScope env) (knLams γ) e--isValid :: IORef (M.HashMap Expr Bool) -> [(Symbol, Sort)] -> Knowledge -> Expr -> SmtM Bool-isValid cacheRef bs γ e = do-    smtCache <- liftIO $ readIORef cacheRef-    case M.lookup e smtCache of-      Nothing -> do-        b <- knPreds γ bs (knLams γ) e-        when b $-          liftIO $ writeIORef cacheRef (M.insert e True smtCache)-        return b-      Just b -> return b--knowledge :: Config -> SInfo a -> Knowledge-knowledge cfg si = KN-  { knSims                     = Map.fromListWith (++) $-                                   [ (smDC rw, [(rw, NoUserDataSMeasure)]) | rw <- sims ] ++-                                   [ (smDC rw, [(rw, UserDataSMeasure)]) | rw <- dataSims ]-  , knAms                      = Map.fromList [(eqName eq, eq) | eq <- aenvEqs aenv]-  , knPreds                    = askSMT cfg-  , knLams                     = []-  , knSummary                  =    ((\s -> (smName s, 1)) <$> sims)-                                 ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)-                                 ++ rwSyms-  , knDCs                      = S.fromList (smDC <$> sims)-  , knDataCtors                = M.fromList [ (val (dcName dc), dc) | dd <- ddecls si, dc <- ddCtors dd ]-  , knSels                     = Mb.mapMaybe makeSel  sims-  , knConsts                   = Mb.mapMaybe makeCons sims-  , knAutoRWs                  = aenvAutoRW aenv-  , knRWTerminationOpts        =-      if rwTermination cfg-      then RWTerminationCheckEnabled-      else RWTerminationCheckDisabled-  }-  where-    (simDCTests, sims0) =-      partitionUserDataConstructorTests (ddecls si) $ aenvSimpl aenv-    (simDCSelectors, sims) =-      partitionUserDataConstructorSelectors (ddecls si) sims0-    dataSims = simDCTests ++ simDCSelectors-    aenv = ae si--    inRewrites :: Symbol -> Bool-    inRewrites e =-      let-        symbs = Mb.mapMaybe (lhsHead . arLHS) (concat $ M.elems $ aenvAutoRW aenv)-      in-        e `L.elem` symbs--    lhsHead :: Expr -> Maybe Symbol-    lhsHead e | (ef, _) <- splitEAppThroughECst e, EVar f <- dropECst ef = Just f-    lhsHead _ = Nothing---    rwSyms = filter (inRewrites . fst) $ map toSum (toListSEnv (gLits si))-      where-        toSum (sym, sort)      = (sym, getArity sort)--        getArity (FFunc _ rhs) = 1 + getArity rhs-        getArity _             = 0----    makeCons rw-      | null (syms $ smBody rw)-      = Just (smName rw, (smDC rw, smBody rw))-      | otherwise-      = Nothing--    makeSel rw-      | EVar x <- smBody rw-      = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw)-      | otherwise-      = Nothing---- | Partitions the input rewrites into constructor tests and others.------ We don't need to deal in PLE with data constructor tests. That is,--- functions of the form @isCons :: List a -> Bool@ or @isNil :: List a -> Bool@--- when @List a@ is defined by the user.------ The SMT solver knows about these functions when datatypes are declared to it,--- so PLE doesn't need to unfold them.------ Non-user defined datatypes like @[a]@ still need to have tests unfolded--- because they are not declared as datatypes to the SMT solver.------ Also, REST could need this functions unfolded since otherwise it may not--- discover possible rewrites.----partitionUserDataConstructorTests :: [DataDecl] -> [Rewrite] -> ([Rewrite], [Rewrite])-partitionUserDataConstructorTests dds rws = L.partition isDataConstructorTest rws-  where-    isDataConstructorTest sm = isTestSymbol (smName sm) && S.member (smDC sm) userDefinedDcs-    userDefinedDcs =-      S.fromList [ symbol (dcName dc) | dd <- dds, dc <- ddCtors dd ]---- | Like 'partitionUserDataConstructorTests' but for selectors.-partitionUserDataConstructorSelectors :: [DataDecl] -> [Rewrite] -> ([Rewrite], [Rewrite])-partitionUserDataConstructorSelectors dds rws = L.partition isSelector rws-  where-    isSelector sm = S.member (smName sm) userDefinedDcFieldsSelectors-    userDefinedDcFieldsSelectors =-      S.fromList [ symbol dcf | dd <- dds, dc <- ddCtors dd, dcf <- dcFields dc ]--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi,--- i.e., sel_i selects the ith value for the data constructor D-type SelectorMap = [(Symbol, (Symbol, Int))]-type ConstDCMap = [(Symbol, (Symbol, Expr))]---- ValueMap maps expressions to constants (including data constructors)-type ConstMap = M.HashMap Expr Expr-type LDataCon = Symbol              -- Data Constructors--isConstant :: S.HashSet LDataCon -> Expr -> Bool-isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs)--simplify :: Knowledge -> ICtx -> Expr -> Expr-simplify γ ictx exprs = mytracepp ("simplification of " ++ showpp exprs) $ fix' (Vis.mapExprOnExpr tx) exprs-    where-      fix' f e = if e == e' then e else fix' f e' where e' = f e-      tx e-        | Just e' <- M.lookup e (icSimpl ictx)-        = e'--      tx (PAtom rel e1 e2) = applyBooleanFolding rel e1 e2-      tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2-      tx (ENeg e)         = applyConstantFolding Minus (ECon (I 0)) e-      tx (EApp e1 e2)-        | isSetPred e1    = applySetFolding e1 e2--      tx (EApp ef a)-        | EVar f <- dropECst ef-        , Just (dc, c)  <- L.lookup f (knConsts γ)-        , (ed, _) <- splitEAppThroughECst a-        , EVar dc' <- dropECst ed-        , dc == dc'-        = c-      tx (EIte b e1 e2)-        | isTautoPred b  = e1-        | isContraPred b = e2-      tx (ECoerc s t e)-        | s == t = e-      tx (EApp ef a)-        | EVar f <- dropECst ef-        , Just (dc, i)  <- L.lookup f (knSels γ)-        , (ed, es) <- splitEAppThroughECst a-        , EVar dc' <- dropECst ed-        , dc == dc'-        = es!!i-      tx e = e------------------------------------------------------------------------------------- | Normalization of Equation: make their arguments unique -----------------------------------------------------------------------------------------------------class Normalizable a where-  normalize :: a -> a--instance Normalizable (GInfo c a) where-  normalize si = si {ae = normalize $ ae si}--instance Normalizable AxiomEnv where-  normalize aenv = aenv { aenvEqs   = mytracepp "aenvEqs"  (normalize <$> aenvEqs   aenv)-                        , aenvSimpl = mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) }--instance Normalizable Rewrite where-  normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw }-    where-      su  = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'-      xs  = smArgs rw-      xs' = zipWith mkSymbol xs [0 :: Integer ..]-      mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i---instance Normalizable Equation where-  normalize eq = eq {eqArgs = zip xs' ss, eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq }-    where-      su      = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'-      (xs,ss) = unzip (eqArgs eq)-      xs'     = zipWith mkSymbol xs [0 :: Integer ..]-      mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i---- | Normalize the given named expression if it is recursive.-normalizeBody :: Symbol -> Expr -> Expr-normalizeBody f exprs | f `elem` syms exprs = go exprs-  where-    -- @go@ performs this simplification:-    --     (c => e1) /\ ((not c) => e2) --> if c then e1 else e2-    -- and then recurses into  e2.-    ---    -- The expressions originate from Haskell's reflect annotations, so we know-    -- that e1 is a conjunction of data constructor checkers and we do not need-    -- to recurse into e1.-    go (PAnd [PImp c e1, PImp (PNot c') e2]) | c == c' = EIte c e1 (go e2)-    go e                                               = e-normalizeBody _ e = e -- The expression is not recursive, return it unchanged.---- -- TODO:FUEL Config--- maxFuel :: Int--- maxFuel = 11---- | Increment the fuel count of the given symbol in the current evaluation--- environment.-useFuel :: Symbol -> EvalST ()-useFuel f = do-  modify (\st -> st { evFuel = useFuelCount f (evFuel st) })---- | Increment the fuel count.-useFuelCount :: Symbol -> FuelCount -> FuelCount-useFuelCount f fc = fc { fcMap = M.insert f (k + 1) m }-  where-    k             = M.lookupDefault 0 f m-    m             = fcMap fc--makeFreshEtaNames :: Int -> EvalST [Symbol]-makeFreshEtaNames n = replicateM n makeFreshName-  where-    makeFreshName = do-      ident <- gets freshEtaNames-      modify $ \st -> st { freshEtaNames = 1 + freshEtaNames st }-      pure $ etaExpSymbol ident--elaborateExpr :: String -> Expr -> EvalST Expr-elaborateExpr msg e = do-  let elabSpan = atLoc dummySpan msg-  env <- get-  let symEnv' = insertsSymEnv (evEnv env) (evExScope env)-  ef <- gets evElabF-  pure $ unApply $ elaborate (ElabParam ef elabSpan symEnv') e---- | Returns False if there is a fuel count in the evaluation environment and--- the fuel count exceeds the maximum. Returns True otherwise.-checkFuel :: Symbol -> EvalST Bool-checkFuel f = do-  fc <- gets evFuel-  case (M.lookup f (fcMap fc), fcMax fc) of-    (Just fk, Just n) -> pure (fk <= n)-    _                 -> pure True----- Note [Existential quantification when unfolding]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ After FUSION is performed, some predicates, which previously used kvars, may--- contain existential quantifications.------ When the unfoldings are searched by PLE in expressions with existentials,--- we make sure that the produced unfoldings still have the existential--- bindings in scope.------ The procedure is as follows:--- 1. First, we rename the existential variables in the predicates of the bindings---    to make them unique ('renameExistentialsInSortedRefts').------    @exists x y. f x y || (exists x. g x y)@------    becomes------    @exists v0 v1. f v0 v1 || (exists v2. g v2 v1)@------ 2. We extract the nested existentials to prenex form, and we store the bodies of---    the existentials in a map with the existential binders as keys---    ('prenexExistentials' and 'updCtx').------    @exists v0 v1. f v0 v1 || (exists v2. g v2 v1)@------    produces the map------    @[v0, v1, v2] -> f v0 v1 || g v2 v1@------ 3. We declare to the SMT solver the existential variables in every scope---    (in 'withAssms').------ 4. We then look for unfoldings in each of the subexpressions. Whenever---    we find an unfolding, we record the scope in which it was found.------    @[v0, v1, v3] -> (f v0 v1 = v0 < v1) && (g v2 = v2 > v1)@------ 5. When PLE is finished, we create for every scope an existential---    quantification whose body contains all the corresponding unfoldings---    and the original subexpressions in the scope ('reconstructExistentials').------    @exists v0 v1 v0.---       (f v0 v 1 = v0 < v1) && (g v2 = v2 > v1) &&---       (f v0 v1 || g v2 v1)@------    This is the expression that PLE returns.----- | Renames existential variables in the predicates of the given bindings to--- make them unique.------ Rather than looking for all existential bindings, this function only renames--- the superficial existentials which can be introduced by KVar solutions.------ These superficial existentials appear in conjunctions, disjunctions and in the--- body of other existentials only.-renameExistentialsInSortedRefts-  :: [(Symbol, SortedReft)]-  -> Int-  -> ([(Symbol, SortedReft)], Int)-renameExistentialsInSortedRefts binds0 existentialCounter =-    let-        binds = [ (x, sr { sr_reft = mapPredReft (const p) (sr_reft sr) }) | ((x, sr), p) <- zip binds0 preds ]-        (preds, existentialCounter') =-          renameKVarExistentials (map (reftPred . sr_reft . snd) binds0) existentialCounter-     in-        (binds, existentialCounter')--renameKVarExistentials :: [Expr] -> Int -> ([Expr], Int)-renameKVarExistentials = runState . mapM go-  where-    go (POr es) = POr <$> mapM go es-    go (PAnd es) = PAnd <$> mapM go es-    go (PExist bs e0) = do-      i1 <- get-      let i2 = i1 + length bs-      put i2-      let vs = map fst bs-          vs' = [ existSymbol v (fromIntegral i) | (v, i) <- zip vs [i1..] ]-          bs' = zip vs' (map snd bs)-          su = mkSubst $ zip vs (map EVar vs')-      PExist bs' <$> go (rapierSubstExpr (S.fromList vs') su e0)-    go e = pure e---- ^ Scopes of existential binders identifying the location of sub-expressions-type ExScope = [(Symbol, Sort)]----- | Extracts nested existentials from an expression.------ For example, the expression------ > exists [x1 : t1]. e1 == e2 &&--- > exists [x2 : t2]. e3 == 2 &&--- > exists [x3 : t3]. e3 < e4------ would be flattened into------ > (e1 == e2 && e3 == 2 && e3 < e4, [x1 : t1, x2 : t2, x3 : t3])------ Precondition: the existential binding names are unique.----prenexExistentials :: Expr -> (ExScope, Expr)-prenexExistentials = go-  where-    go :: Expr -> (ExScope, Expr)-    go (PExist bs e) =-      let (bs', e') = go e-      in (bs ++ bs', e')-    go (PAnd es) =-      let (bss, es') = unzip (map go es)-      in (concat bss, PAnd es')-    go (POr es) =-      let (bss, es') = unzip (map go es)-      in (concat bss, POr es')-    go e = ([], e)----- | Reconstructs expressions with existentials from a map--- of existential scopes to their bodies.-reconstructExistentials :: M.HashMap ExScope (S.HashSet Expr) -> [Expr]-reconstructExistentials m = [ pExist s (pAndNoDedup $ S.toList es) | (s, es) <- M.toList m, not (null es) ]+-- | This module implements "Proof by Logical Evaluation" where we +--   unfold function definitions if they *must* be unfolded, to strengthen+--   the environments with function-definition-equalities. +--   The algorithm is discussed at length in:+-- +--     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842+--     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf +--------------------------------------------------------------------------------++{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE ViewPatterns              #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ExistentialQuantification #-}++module Language.Fixpoint.Solver.PLE (instantiate) where++import           Language.Fixpoint.Types hiding (simplify)+import           Language.Fixpoint.Types.Config  as FC+import           Language.Fixpoint.Types.Solutions (CMap)+import qualified Language.Fixpoint.Types.Visitor as Vis+import qualified Language.Fixpoint.Misc          as Misc +import qualified Language.Fixpoint.Smt.Interface as SMT+import           Language.Fixpoint.Defunctionalize+import qualified Language.Fixpoint.Utils.Files   as Files+import qualified Language.Fixpoint.Utils.Trie    as T +import           Language.Fixpoint.Utils.Progress +import           Language.Fixpoint.SortCheck+import           Language.Fixpoint.Graph.Deps             (isTarget) +import           Language.Fixpoint.Solver.Sanitize        (symbolEnv)+import           Language.Fixpoint.Solver.Rewrite++import Language.REST.AbstractOC as OC+import Language.REST.ExploredTerms as ET+import Language.REST.RuntimeTerm as RT+import Language.REST.OrderingConstraints.ADT (ConstraintsADT)+import Language.REST.Op+import Language.REST.SMT (withZ3, SolverHandle)++import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import           Data.Bifunctor (second)+import qualified Data.HashMap.Strict  as M+import qualified Data.HashSet         as S+import qualified Data.List            as L+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe           as Mb+import qualified Data.Text            as Tx+import           Debug.Trace          (trace)+import           Text.PrettyPrint.HughesPJ.Compat++-- Type of Ordering Constraints for REST+type OCType = ConstraintsADT++mytracepp :: (PPrint a) => String -> a -> a+mytracepp = notracepp++traceE :: (Expr,Expr) -> (Expr,Expr)+traceE (e,e')+  | isEnabled+  , e /= e'+  = trace ("\n" ++ showpp e ++ " ~> " ++ showpp e') (e,e')+  | otherwise+  = (e,e')+  where+    isEnabled :: Bool+    isEnabled = False++--------------------------------------------------------------------------------+-- | Strengthen Constraint Environments via PLE +--------------------------------------------------------------------------------+{-# SCC instantiate #-}+instantiate :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+instantiate cfg fi' subcIds = do+    let cs = M.filterWithKey+               (\i c -> isPleCstr aEnv i c && maybe True (i `L.elem`) subcIds)+               (cm fi)+    let t  = mkCTrie (M.toList cs)                                          -- 1. BUILD the Trie+    res   <- withRESTSolver $ \solver -> withProgress (1 + M.size cs) $+               withCtx cfg file sEnv (pleTrie t . instEnv cfg fi cs solver) -- 2. TRAVERSE Trie to compute InstRes+    savePLEEqualities cfg fi res+    return $ resSInfo cfg sEnv fi res                                       -- 3. STRENGTHEN SInfo using InstRes+  where+    withRESTSolver :: (Maybe SolverHandle -> IO a) -> IO a+    withRESTSolver f | null (concat $ M.elems $ aenvAutoRW aEnv) = f Nothing+    withRESTSolver f | otherwise = withZ3 (\z3 -> f (Just z3))++    file   = srcFile cfg ++ ".evals"+    sEnv   = symbolEnv cfg fi+    aEnv   = ae fi +    fi     = normalize fi' ++savePLEEqualities :: Config -> SInfo a -> InstRes -> IO ()+savePLEEqualities cfg fi res = when (save cfg) $ do+    let fq   = queryFile Files.Fq cfg ++ ".ple"+    putStrLn $ "\nSaving PLE equalities: "   ++ fq ++ "\n"+    Misc.ensurePath fq+    let constraint_equalities =+          map equalitiesPerConstraint $ Misc.hashMapToAscList $ cm fi+    writeFile fq $ render $ vcat $+      map renderConstraintRewrite constraint_equalities+  where+    equalitiesPerConstraint (cid, c) =+      (cid, L.sort [ e | i <- elemsIBindEnv (senv c), Just e <- [M.lookup i res] ])+    renderConstraintRewrite (cid, eqs) =+      "constraint id" <+> text (show cid ++ ":")+      $+$ nest 2 (toFix (pAnd eqs))+      $+$ ""++------------------------------------------------------------------------------- +-- | Step 1a: @instEnv@ sets up the incremental-PLE environment +instEnv :: (Loc a) => Config -> SInfo a -> CMap (SimpC a) -> Maybe SolverHandle -> SMT.Context -> InstEnv a+instEnv cfg fi cs restSolver ctx = InstEnv cfg ctx bEnv aEnv cs γ s0+  where+    bEnv              = bs fi+    aEnv              = ae fi+    γ                 = knowledge cfg ctx fi  +    s0                = EvalEnv (SMT.ctxSymEnv ctx) mempty (defFuelCount cfg) et restSolver+    et                = fmap makeET restSolver+    makeET solver     =+      ET.empty (EF (OC.union (ordConstraints solver)) (OC.notStrongerThan (ordConstraints solver)))++---------------------------------------------------------------------------------------------- +-- | Step 1b: @mkCTrie@ builds the @Trie@ of constraints indexed by their environments+--+-- The trie is a way to unfold the equalities a minimum number of times.+-- Say you have+--+-- > 1: [1, 2, 3, 4, 5] => p1+-- > 2: [1, 2, 3, 6, 7] => p2+--+-- Then you build the tree+--+-- >  1 -> 2 -> 3 -> 4 -> 5 — [Constraint 1]+-- >            | -> 6 -> 7 — [Constraint 2]+--+-- which you use to unfold everything in 1, 2, and 3 once (instead of twice)+-- and with the proper existing environment+--+mkCTrie :: [(SubcId, SimpC a)] -> CTrie +mkCTrie ics  = T.fromList [ (cBinds c, i) | (i, c) <- ics ]+  where+    cBinds   = L.sort . elemsIBindEnv . senv ++---------------------------------------------------------------------------------------------- +-- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE+pleTrie :: CTrie -> InstEnv a -> IO InstRes+pleTrie t env = loopT env ctx0 diff0 Nothing res0 t +  where +    diff0        = []+    res0         = M.empty +    ctx0         = initCtx env ((mkEq <$> es0) ++ (mkEq' <$> es0'))+    es0          = L.filter (null . eqArgs) (aenvEqs   . ieAenv $ env)+    es0'         = L.filter (null . smArgs) (aenvSimpl . ieAenv $ env)+    mkEq  eq     = (EVar $ eqName eq, eqBody eq)+    mkEq' rw     = (EApp (EVar $ smName rw) (EVar $ smDC rw), smBody rw)++loopT+  :: InstEnv a+  -> ICtx+  -> Diff         -- ^ The longest path suffix without forks in reverse order+  -> Maybe BindId -- ^ bind id of the branch ancestor of the trie if any.+                  --   'Nothing' when this is the top-level trie.+  -> InstRes+  -> CTrie+  -> IO InstRes+loopT env ctx delta i res t = case t of+  T.Node []  -> return res+  T.Node [b] -> loopB env ctx delta i res b+  T.Node bs  -> withAssms env ctx delta Nothing $ \ctx' -> do +                  (ctx'', res') <- ple1 env ctx' i res +                  foldM (loopB env ctx'' [] i) res' bs++loopB+  :: InstEnv a+  -> ICtx+  -> Diff         -- ^ The longest path suffix without forks in reverse order+  -> Maybe BindId -- ^ bind id of the branch ancestor of the branch if any.+                  --   'Nothing' when this is a branch of the top-level trie.+  -> InstRes+  -> CBranch+  -> IO InstRes+loopB env ctx delta iMb res b = case b of+  T.Bind i t -> loopT env ctx (i:delta) (Just i) res t+  T.Val cid  -> withAssms env ctx delta (Just cid) $ \ctx' -> do +                  progressTick+                  (snd <$> ple1 env ctx' iMb res) ++-- | Adds to @ctx@ candidate expressions to unfold from the bindings in @delta@+-- and the rhs of @cidMb@.+--+-- Adds to @ctx@ assumptions from @env@ and @delta@ plus rewrites that+-- candidates can use.+--+-- Sets the current constraint id in @ctx@ to @cidMb@.+--+-- Pushes assumptions from the modified context to the SMT solver, runs @act@,+-- and then pops the assumptions.+--+withAssms :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> (ICtx -> IO b) -> IO b +withAssms env@(InstEnv {..}) ctx delta cidMb act = do+  let ctx'  = updCtx env ctx delta cidMb +  let assms = icAssms ctx'+  SMT.smtBracket ieSMT  "PLE.evaluate" $ do+    forM_ assms (SMT.smtAssert ieSMT) +    act ctx' { icAssms = mempty }++-- | @ple1@ performs the PLE at a single "node" in the Trie +ple1 :: InstEnv a -> ICtx -> Maybe BindId -> InstRes -> IO (ICtx, InstRes)+ple1 (InstEnv {..}) ctx i res = +  updCtxRes res i <$> evalCandsLoop ieCfg ctx ieSMT ieKnowl ieEvEnv+++evalToSMT :: String -> Config -> SMT.Context -> (Expr, Expr) -> Pred +evalToSMT msg cfg ctx (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx [] (EEq e1 e2)++evalCandsLoop :: Config -> ICtx -> SMT.Context -> Knowledge -> EvalEnv -> IO ICtx +evalCandsLoop cfg ictx0 ctx γ env = go ictx0 0+  where+    withRewrites exprs =+      let+        rws = [rewrite e (knSims γ) | e <- S.toList (snd `S.map` exprs)]+      in +        exprs <> (S.fromList $ concat rws)+    go ictx _ | S.null (icCands ictx) = return ictx+    go ictx i =  do+                  let cands = icCands ictx+                  let env' = env { evAccum = icEquals ictx <> evAccum env +                                 , evFuel  = icFuel   ictx +                                 }+                  (ictx', evalResults)  <- do+                               SMT.smtAssert ctx (pAndNoDedup (S.toList $ icAssms ictx))+                               let ictx' = ictx { icAssms = mempty }+                               foldM (evalOneCandStep γ env' i) (ictx', []) (S.toList cands)+                               -- foldM (\ictx e -> undefined) +                               -- mapM (evalOne γ env' ictx) (S.toList cands)+                  let us = mconcat evalResults +                  if S.null (us `S.difference` icEquals ictx)+                        then return ictx +                        else do  let oks      = fst `S.map` us+                                 let us'      = withRewrites us +                                 let eqsSMT   = evalToSMT "evalCandsLoop" cfg ctx `S.map` us'+                                 let ictx''   = ictx' { icSolved = icSolved ictx <> oks +                                                      , icEquals = icEquals ictx <> us'+                                                      , icAssms  = S.filter (not . isTautoPred) eqsSMT }+                                 let newcands = mconcat (makeCandidates γ ictx'' <$> S.toList (cands <> (snd `S.map` us)))+                                 go (ictx'' { icCands = S.fromList newcands}) (i + 1)+                                 +evalOneCandStep :: Knowledge -> EvalEnv -> Int -> (ICtx, [EvAccum]) -> Expr -> IO (ICtx, [EvAccum])+evalOneCandStep γ env' i (ictx, acc) e = do+  (res, fm) <- evalOne γ env' ictx i e+  return (ictx { icFuel = fm}, res : acc)++rewrite :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)] +rewrite e rwEnv = concat $ map (`rewriteTop` rwEnv) (notGuardedApps e)++rewriteTop :: Expr -> Map Symbol [Rewrite] -> [(Expr,Expr)]+rewriteTop e rwEnv =+  [ (EApp (EVar $ smName rw) e, subst (mkSubst $ zip (smArgs rw) es) (smBody rw))+  | (EVar f, es) <- [splitEApp e]+  , Just rws <- [Map.lookup f rwEnv]+  , rw <- rws+  , length es == length (smArgs rw)+  ]++---------------------------------------------------------------------------------------------- +-- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo +---------------------------------------------------------------------------------------------- ++resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a+resSInfo cfg env fi res = strengthenBinds fi res' +  where+    res'     = M.fromList $ zip is ps''+    ps''     = zipWith (\i -> elaborate (atLoc dummySpan ("PLE1 " ++ show i)) env) is ps' +    ps'      = defuncAny cfg env ps+    (is, ps) = unzip (M.toList res)++---------------------------------------------------------------------------------------------- +-- | @InstEnv@ has the global information needed to do PLE+---------------------------------------------------------------------------------------------- ++data InstEnv a = InstEnv +  { ieCfg   :: !Config+  , ieSMT   :: !SMT.Context+  , ieBEnv  :: !BindEnv+  , ieAenv  :: !AxiomEnv +  , ieCstrs :: !(CMap (SimpC a))+  , ieKnowl :: !Knowledge+  , ieEvEnv :: !EvalEnv+  } ++---------------------------------------------------------------------------------------------- +-- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE+---------------------------------------------------------------------------------------------- ++data ICtx    = ICtx +  { icAssms    :: S.HashSet Pred            -- ^ Equalities converted to SMT format+  , icCands    :: S.HashSet Expr            -- ^ "Candidates" for unfolding+  , icEquals   :: EvAccum                   -- ^ Accumulated equalities+  , icSolved   :: S.HashSet Expr            -- ^ Terms that we have already expanded+  , icSimpl    :: !ConstMap                 -- ^ Map of expressions to constants+  , icSubcId   :: Maybe SubcId              -- ^ Current subconstraint ID+  , icFuel     :: !FuelCount                -- ^ Current fuel-count+  , icANFs     :: S.HashSet Pred            -- Hopefully contain only ANF things+  } ++---------------------------------------------------------------------------------------------- +-- | @InstRes@ is the final result of PLE; a map from @BindId@ to the equations "known" at that BindId+---------------------------------------------------------------------------------------------- ++type InstRes = M.HashMap BindId Expr++---------------------------------------------------------------------------------------------- +-- | @Unfold is the result of running PLE at a single equality; +--     (e, [(e1, e1')...]) is the source @e@ and the (possible empty) +--   list of PLE-generated equalities (e1, e1') ... +---------------------------------------------------------------------------------------------- ++type CTrie   = T.Trie   SubcId+type CBranch = T.Branch SubcId+type Diff    = [BindId]    -- ^ in "reverse" order++initCtx :: InstEnv a -> [(Expr,Expr)] -> ICtx+initCtx env es   = ICtx +  { icAssms  = mempty +  , icCands  = mempty +  , icEquals = S.fromList es+  , icSolved = mempty+  , icSimpl  = mempty +  , icSubcId = Nothing+  , icFuel   = evFuel (ieEvEnv env)+  , icANFs   = mempty+  }++equalitiesPred :: S.HashSet (Expr, Expr) -> [Expr]+equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- S.toList eqs, e1 /= e2 ] ++updCtxRes :: InstRes -> Maybe BindId -> ICtx -> (ICtx, InstRes) +updCtxRes res iMb ctx = (ctx, res')+  where +    res' = updRes res iMb (pAnd $ equalitiesPred $ icEquals ctx)+++updRes :: InstRes -> Maybe BindId -> Expr -> InstRes+updRes res (Just i) e = M.insertWith (error "tree-like invariant broken in ple. See https://github.com/ucsd-progsys/liquid-fixpoint/issues/496") i e res+updRes res  Nothing _ = res ++---------------------------------------------------------------------------------------------- +-- | @updCtx env ctx delta cidMb@ adds the assumptions and candidates from @delta@ and @cidMb@ +--   to the context. +---------------------------------------------------------------------------------------------- ++updCtx :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx+updCtx InstEnv {..} ctx delta cidMb +              = ctx { icAssms  = S.fromList (filter (not . isTautoPred) ctxEqs)  +                    , icCands  = S.fromList cands           <> icCands  ctx+                    , icEquals = initEqs                    <> icEquals ctx+                    , icSimpl  = M.fromList (S.toList sims) <> icSimpl ctx <> econsts+                    , icSubcId = cidMb+                    , icANFs   = anfs <> icANFs ctx+                    }+  where         +    initEqs   = S.fromList $ concat [rewrite e (knSims ieKnowl) | e  <- cands]+    anfs      = S.fromList (toSMT "updCtx" ieCfg ieSMT [] <$> L.nub [ expr xr | xr <- bs ])+    cands     = concatMap (makeCandidates ieKnowl ctx) (rhs:es)+    sims      = S.filter (isSimplification (knDCs ieKnowl)) (initEqs <> icEquals ctx)+    econsts   = M.fromList $ findConstants ieKnowl es+    ctxEqs    = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub (concat+                  [ equalitiesPred initEqs +                  , equalitiesPred sims +                  , equalitiesPred (icEquals ctx)+                  , [ expr xr   | xr@(_, r) <- bs, null (Vis.kvarsExpr $ reftPred $ sr_reft r) ]+                  ])+    bs        = second unElabSortedReft <$> binds+    (rhs:es)  = unElab <$> (eRhs : (expr <$> binds))+    eRhs      = maybe PTrue crhs subMb+    binds     = [ lookupBindEnv i ieBEnv | i <- delta ]+    subMb     = getCstr ieCstrs <$> cidMb+++findConstants :: Knowledge -> [Expr] -> [(Expr, Expr)]+findConstants γ es = [(EVar x, c) | (x,c) <- go [] (concatMap splitPAnd es)]  +  where +    go su ess = if ess == ess' +                  then su +                  else go (su ++ su') ess' +       where ess' = subst (mkSubst su') <$> ess+             su'  = makeSu ess +    makeSu exprs  = [(x,c) | (EEq (EVar x) c) <- exprs +                           , isConstant (knDCs γ) c+                           , EVar x /= c ]++makeCandidates :: Knowledge -> ICtx -> Expr -> [Expr]+makeCandidates γ ctx expr +  = mytracepp ("\n" ++ show (length cands) ++ " New Candidates") cands+  where +    cands = filter (\e -> isRedex γ e && not (e `S.member` icSolved ctx)) (notGuardedApps expr)++isRedex :: Knowledge -> Expr -> Bool +isRedex γ e = isGoodApp γ e || isIte e +  where +    isIte EIte {} = True +    isIte _       = False +++isGoodApp :: Knowledge -> Expr -> Bool +isGoodApp γ e +  | (EVar f, es) <- splitEApp e+  , Just i       <- L.lookup f (knSummary γ)+  = length es >= i+  | otherwise+  = False +    ++++getCstr :: M.HashMap SubcId (SimpC a) -> SubcId -> SimpC a +getCstr env cid = Misc.safeLookup "Instantiate.getCstr" cid env++isPleCstr :: AxiomEnv -> SubcId -> SimpC a -> Bool+isPleCstr aenv sid c = isTarget c && M.lookupDefault False sid (aenvExpand aenv) ++type EvAccum = S.HashSet (Expr, Expr)++--------------------------------------------------------------------------------+data EvalEnv = EvalEnv+  { evEnv      :: !SymEnv+  , evAccum    :: EvAccum+  , evFuel     :: FuelCount++  -- REST parameters+  , explored   :: Maybe (ExploredTerms RuntimeTerm (OCType Op) IO)+  , restSolver :: Maybe SolverHandle+  }++data FuelCount = FC +  { fcMap :: M.HashMap Symbol Int+  , fcMax :: Maybe Int+  } +  deriving (Show)++defFuelCount :: Config -> FuelCount+defFuelCount cfg = FC mempty (fuel cfg)++type EvalST a = StateT EvalEnv IO a+--------------------------------------------------------------------------------+++getAutoRws :: Knowledge -> ICtx -> [AutoRewrite]+getAutoRws γ ctx =+  Mb.fromMaybe [] $ do+    cid <- icSubcId ctx+    M.lookup cid $ knAutoRWs γ++evalOne :: Knowledge -> EvalEnv -> ICtx -> Int -> Expr -> IO (EvAccum, FuelCount)+evalOne γ env ctx i e | i > 0 || null (getAutoRws γ ctx) = do+    ((e', _), st) <- runStateT (eval γ ctx NoRW e) (env { evFuel = icFuel ctx })+    let evAcc' = if (mytracepp ("evalOne: " ++ showpp e) e') == e then evAccum st else S.insert (e, e') (evAccum st)+    return (evAcc', evFuel st) +evalOne γ env ctx _ e | otherwise = do+  env' <- execStateT (evalREST γ ctx rp) (env { evFuel = icFuel ctx })+  return (evAccum env', evFuel env')+  where+    oc :: AbstractOC (OCType Op) Expr IO+    oc = ordConstraints (Mb.fromJust $ restSolver env)++    rp = RP oc [(e, PLE)] constraints+    constraints = foldl go (OC.top oc) []+      where+        go c (t, u) = refine oc c t u+++-- | @notGuardedApps e@ yields all the subexpressions that are+-- applications not under an if-then-else, lambda abstraction, type abstraction,+-- type application, or quantifier.+notGuardedApps :: Expr -> [Expr]+notGuardedApps = go +  where +    go e@(EApp e1 e2)  = [e] ++ go e1 ++ go e2+    go (PAnd es)       = concatMap go es+    go (POr es)        = concatMap go es+    go (PAtom _ e1 e2) = go e1  ++ go e2+    go (PIff e1 e2)    = go e1  ++ go e2+    go (PImp e1 e2)    = go e1  ++ go e2 +    go (EBin  _ e1 e2) = go e1  ++ go e2+    go (PNot e)        = go e+    go (ENeg e)        = go e+    go e@(EIte b _ _)  = go b ++ [e] -- ++ go e1 ++ go e2  +    go (ECoerc _ _ e)  = go e +    go (ECst e _)      = go e +    go (ESym _)        = []+    go (ECon _)        = []+    go (EVar _)        = []+    go (ELam _ _)      = []+    go (ETApp _ _)     = []+    go (ETAbs _ _)     = []+    go (PKVar _ _)     = []+    go (PAll _ _)      = []+    go (PExist _ _)    = []+    go (PGrad{})       = []++++-- The FuncNormal and RWNormal evaluation strategies are used for REST+-- For example, consider the following function:+--   add(x, y) = if x == 0 then y else add(x - 1, y + 1)+-- And a rewrite rule:+--   forall a, b . add(a,b) -> add(b, a)+-- Then the expression add(t, add(2, 1)) would evaluate under NoRW to:+--   if t == 0 then 3 else add(t - 1, 4)+-- However, under FuncNormal, it would evaluate to: add(t, 3)+-- Thus, FuncNormal could engage the rewrite rule add(t, 3) = add(3, t)+++data EvalType =+    NoRW       -- Normal PLE+  | FuncNormal -- REST: Expand function definitions only when the branch can be decided+  | RWNormal   -- REST: Fully Expand Defs in the context of rewriting (similar to NoRW)+  deriving (Eq)++-- Indicates whether or not the evaluation has expanded a function statement+-- into a conditional branch.+-- In this case, rewriting should stop+-- It's unclear whether or not rewriting in either branch makes sense,+-- since one branch could be an ill-formed expression.+newtype FinalExpand = FE Bool deriving (Show)++noExpand :: FinalExpand+noExpand = FE False++expand :: FinalExpand+expand = FE True++mapFE :: (Expr -> Expr) -> (Expr, FinalExpand) -> (Expr, FinalExpand)+mapFE f (e, fe) = (f e, fe)++feVal :: FinalExpand -> Bool+feVal (FE f) = f++feAny :: [FinalExpand] -> FinalExpand+feAny xs = FE $ any id (map feVal xs)++(<|>) :: FinalExpand -> FinalExpand -> FinalExpand+(<|>) (FE True) _ = expand+(<|>) _         f = f+++feSeq :: [(Expr, FinalExpand)] -> ([Expr], FinalExpand)+feSeq xs = (map fst xs, feAny (map snd xs))++-- | Unfolds expressions using rewrites and equations.+--+-- Also reduces if-then-else when the boolean condition or the negation can be+-- proved valid. This is the actual implementation of guard-validation-before-unfolding+-- that is described in publications.+--+-- Also folds constants.+--+-- Also adds to the monad state all the subexpressions that have been rewritten+-- as pairs @(original_subexpression, rewritten_subexpression)@.+--+eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand)+eval _ ctx _ e+  | Just v <- M.lookup e (icSimpl ctx)+  = return (v, noExpand)+  +eval γ ctx et e =+  do acc <- gets (S.toList . evAccum)+     case L.lookup e acc of+        -- If rewriting, don't lookup, as evAccum may contain loops+        Just e' | null (getAutoRws γ ctx) -> eval γ ctx et e'+        _ -> do+          (e0', fe)  <- go e+          let e' = simplify γ ctx e0'+          if e /= e' +            then+              case et of+                NoRW -> do+                  modify (\st -> st { evAccum = S.insert (traceE (e, e')) (evAccum st) })+                  (e'',  fe') <- eval γ (addConst (e,e') ctx) et e'+                  return (e'', fe <|> fe')+                _ -> return (e', fe)+            else +              return (e, fe)+  where+    addConst (e,e') ctx = if isConstant (knDCs γ) e'+                           then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx +    go (ELam (x,s) e)   = mapFE (ELam (x, s)) <$> eval γ' ctx et e where γ' = γ { knLams = (x, s) : knLams γ }+    go (EIte b e1 e2) = evalIte γ ctx et b e1 e2+    go (ECoerc s t e)   = mapFE (ECoerc s t)  <$> go e+    go e@(EApp _ _)     =+      case splitEApp e of+       (f, es) | et == RWNormal ->+          -- Just evaluate the arguments first, to give rewriting a chance to step in+          -- if necessary+          do+            (es', fe) <- feSeq <$> mapM (eval γ ctx et) es+            r <- if es /= es'+              then return (eApps f es', fe)+              else do+                (f', fe)  <- eval γ ctx et f+                (e', fe') <- evalApp γ ctx f' es et+                return $ (e', fe <|> fe')+            return r+       (f, es) ->+          do+            ((f':es'), fe) <- feSeq <$> mapM (eval γ ctx et) (f:es)+            (e', fe') <- evalApp γ ctx f' es' et+            return $ (e', fe <|> fe')++    go e@(PAtom r e1 e2) = evalBoolOr e (binOp (PAtom r) e1 e2)+    go (ENeg e)         = do (e', fe)  <- eval γ ctx et e+                             return $ ((ENeg e'), fe)+    go (EBin o e1 e2)   = do (e1', fe1) <- eval γ ctx et e1+                             (e2', fe2) <- eval γ ctx et e2+                             return (EBin o e1' e2', fe1 <|> fe2)+    go (ETApp e t)      = mapFE (flip ETApp t) <$> go e+    go (ETAbs e s)      = mapFE (flip ETAbs s) <$> go e+    go e@(PNot e')      = evalBoolOr e (mapFE PNot <$> go e')+    go e@(PImp e1 e2)   = evalBoolOr e (binOp PImp e1 e2)+    go e@(PIff e1 e2)   = evalBoolOr e (binOp PIff e1 e2)+    go e@(PAnd es)      = evalBoolOr e (efAll PAnd (go  <$$> es))+    go e@(POr es)       = evalBoolOr e (efAll POr (go <$$> es))+    go e                = return (e, noExpand)++    binOp f e1 e2 = do+      (e1', fe1) <- go e1+      (e2', fe2) <- go e2+      return (f e1' e2', fe1 <|> fe2)++    efAll f mes = do+      xs <- mes+      let (xs', fe) = feSeq xs+      return (f xs', fe)++    evalBoolOr :: Expr -> EvalST (Expr, FinalExpand) -> EvalST (Expr, FinalExpand)+    evalBoolOr ee fallback = do+      b <- evalBool γ ee+      case b of+        Just r  -> return (r, noExpand)+        Nothing -> fallback++data RESTParams oc = RP+  { oc   :: AbstractOC oc Expr IO+  , path :: [(Expr, TermOrigin)]+  , c    :: oc+  }++getANFSubs :: Expr -> [(Symbol, Expr)]+getANFSubs (PAnd es)                                   = concatMap getANFSubs es+getANFSubs (EEq lhs rhs) | (EVar v) <- unElab lhs+                           , anfPrefix `isPrefixOfSym` v = [(v, unElab rhs)]+getANFSubs (EEq lhs rhs) | (EVar v) <- unElab rhs+                           , anfPrefix `isPrefixOfSym` v = [(v, unElab lhs)]+getANFSubs _                                           = []++-- Reverse the ANF transformation+deANF :: ICtx -> Expr -> Expr+deANF ctx e = subst' e where+  ints  = concatMap getANFSubs (S.toList $ icANFs ctx)+  ints' = map go (L.groupBy (\x y -> fst x == fst y) $ L.sortOn fst $ L.nub ints) where+    go ([(t, u)]) = (t, u)+    go ts         = (fst (head ts), getBest (map snd ts))+  su          = Su (M.fromList ints')+  subst' ee =+    let+      ee' = subst su ee+    in+      if ee == ee'+        then ee+        else subst' ee'++  getBest ts | Just t <- L.find isVar ts = t+    where+      -- Hack : Vars starting with ds_ are probably constants+      isVar (EVar t) = not $ Tx.isPrefixOf "ds_" (symbolText t)+      isVar _        = False++  -- If the only match is a ds_ var, use it+  getBest ts | Just t <- L.find isVar ts = t+    where+      isVar (EVar _) = True+      isVar _        = False++  getBest ts | otherwise = head ts++-- |+-- Adds to the monad state all the subexpressions that have been rewritten+-- as pairs @(original_subexpression, rewritten_subexpression)@.+--+-- Also folds constants.+--+-- The main difference with 'eval' is that 'evalREST' takes into account+-- autorewrites.+--+evalREST :: Knowledge -> ICtx -> RESTParams (OCType Op) -> EvalST ()+evalREST _ ctx rp+  | pathExprs <- map fst (mytracepp "EVAL1: path" $ path rp)+  , e         <- last pathExprs+  , Just v    <- M.lookup e (icSimpl ctx)+  = when (v /= e) $ modify (\st -> st { evAccum = S.insert (e, v) (evAccum st)})+        +evalREST γ ctx rp =+  do+    Just exploredTerms <- gets explored+    se <- liftIO (shouldExploreTerm exploredTerms e)+    when se $ do+      possibleRWs <- getRWs+      rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed) possibleRWs+      (e', FE fe) <- do+        r@(ec, _) <- eval γ ctx FuncNormal e+        if ec /= e+          then return r+          else eval γ ctx RWNormal e++      let evalIsNewExpr = e' `L.notElem` pathExprs+      let exprsToAdd    = [e' | evalIsNewExpr]  ++ map fst rws+      let evAccum'      = S.fromList $ map (e,) $ exprsToAdd++      modify (\st ->+                st {+                  evAccum  = S.union evAccum' (evAccum st)+                , explored = Just $ ET.insert+                  (convert e)+                  (c rp)+                  (S.insert (convert e') $ S.fromList (map (convert . fst) possibleRWs))+                  (Mb.fromJust $ explored st)+                })++      when evalIsNewExpr $+        if fe && any isRW (path rp)+          then eval γ (addConst (e, e')) NoRW e' >> return ()+          else evalREST γ (addConst (e, e')) (rpEval e')++      mapM_ (\rw -> evalREST γ ctx (rpRW rw)) rws+  where+    shouldExploreTerm et e =+      case rwTerminationOpts rwArgs of+        RWTerminationCheckDisabled -> return $ not $ visited (convert e) et+        RWTerminationCheckEnabled  -> shouldExplore (convert e) (c rp) et++    allowed (rwE, _) | rwE `elem` pathExprs = return False+    allowed (_, c)   | otherwise = termCheck c+    termCheck c = passesTerminationCheck (oc rp) rwArgs c++    notVisitedFirst et rws =+      let+        (v, nv) = L.partition (\(e, _) -> visited (convert e) et) rws+      in+        nv ++ v++    rpEval e' =+      let+        c' =+          if any isRW (path rp)+            then refine (oc rp) (c rp) e e'+            else c rp++      in+        rp{path = path rp ++ [(e', PLE)], c = c'}++    isRW (_, r) = r == RW++    rpRW (e', c') = rp{path = path rp ++ [(e', RW)], c = c' }++    pathExprs       = map fst (mytracepp "EVAL2: path" $ path rp)+    e               = last pathExprs+    autorws         = getAutoRws γ ctx++    rwArgs = RWArgs (isValid γ) $ knRWTerminationOpts γ++    getRWs =+      do+        ok <- if (isRW $ last (path rp)) then (return True) else (liftIO $ termCheck (c rp))+        if ok+          then+            do+              let e'         = deANF ctx e+              let getRW e ar = getRewrite (oc rp) rwArgs (c rp) e ar+              let getRWs' s  = Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRW s) autorws+              concat <$> mapM getRWs' (subExprs e')+          else return []++    addConst (e,e') = if isConstant (knDCs γ) e'+                      then ctx { icSimpl = M.insert e e' $ icSimpl ctx} else ctx ++(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b]+f <$$> xs = f Misc.<$$> xs+++-- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites+-- and equations+evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Expr, FinalExpand)+evalApp γ ctx (EVar f) es et+  | Just eq <- Map.lookup f (knAms γ)+  , length (eqArgs eq) <= length es +  = do +       env  <- gets (seSort . evEnv)+       okFuel <- checkFuel f+       if okFuel && et /= FuncNormal+         then do+                useFuel f+                let (es1,es2) = splitAt (length (eqArgs eq)) es+                shortcut (substEq env eq es1) es2 -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter+         else return $ (eApps (EVar f) es, noExpand)+  where+    shortcut (EIte i e1 e2) es2 = do+      (b, _) <- eval γ ctx et i+      b'  <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValid γ b)+      nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (i, PNot b)) <$> isValid γ (PNot b))+      r <- if b' +        then shortcut e1 es2+        else if nb' then shortcut e2 es2+        else return $ (eApps (EIte b e1 e2) es2, expand)+      return r+    shortcut e' es2 = return $ (eApps e' es2, noExpand)++evalApp γ _ (EVar f) (e:es) _+  | (EVar dc, as) <- splitEApp e+  , Just rws <- Map.lookup dc (knSims γ)+  , Just rw <- L.find (\rw -> smName rw == f) rws+  , length as == length (smArgs rw)+  = return (eApps (subst (mkSubst $ zip (smArgs rw) as) (smBody rw)) es, noExpand)++evalApp _ _ e es _+  = return $ (eApps e es, noExpand)++--------------------------------------------------------------------------------+-- | 'substEq' unfolds or instantiates an equation at a particular list of+--   argument values. We must also substitute the sort-variables that appear+--   as coercions. See tests/proof/ple1.fq+--------------------------------------------------------------------------------+substEq :: SEnv Sort -> Equation -> [Expr] -> Expr+substEq env eq es = subst su (substEqCoerce env eq es)+  where su = mkSubst $ zip (eqArgNames eq) es++substEqCoerce :: SEnv Sort -> Equation -> [Expr] -> Expr+substEqCoerce env eq es = Vis.applyCoSub coSub $ eqBody eq+  where +    ts    = snd    <$> eqArgs eq+    sp    = panicSpan "mkCoSub"+    eTs   = sortExpr sp env <$> es+    coSub = mkCoSub env eTs ts++mkCoSub :: SEnv Sort -> [Sort] -> [Sort] -> Vis.CoSub+mkCoSub env eTs xTs = M.fromList [ (x, unite ys) | (x, ys) <- Misc.groupList xys ] +  where+    unite ts    = Mb.fromMaybe (uError ts) (unifyTo1 senv ts)+    senv        = mkSearchEnv env+    uError ts   = panic ("mkCoSub: cannot build CoSub for " ++ showpp xys ++ " cannot unify " ++ showpp ts) +    xys         = Misc.sortNub $ concat $ zipWith matchSorts _xTs _eTs+    (_xTs,_eTs) = (xTs, eTs)++matchSorts :: Sort -> Sort -> [(Symbol, Sort)]+matchSorts s1 s2 = go s1 s2+  where+    go (FObj x)      {-FObj-} y    = [(x, y)]+    go (FAbs _ t1)   (FAbs _ t2)   = go t1 t2+    go (FFunc s1 t1) (FFunc s2 t2) = go s1 s2 ++ go t1 t2+    go (FApp s1 t1)  (FApp s2 t2)  = go s1 s2 ++ go t1 t2+    go _             _             = []++--------------------------------------------------------------------------------++eqArgNames :: Equation -> [Symbol]+eqArgNames = map fst . eqArgs++evalBool :: Knowledge -> Expr -> EvalST (Maybe Expr) +evalBool γ e = do +  bt <- liftIO $ isValid γ e+  if bt then return $ Just PTrue +   else do +    bf <- liftIO $ isValid γ (PNot e)+    if bf then return $ Just PFalse +          else return Nothing+               +evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> Expr -> Expr -> EvalST (Expr, FinalExpand)+evalIte γ ctx et b0 e1 e2 = do+  (b, fe) <- eval γ ctx et b0+  b'  <- liftIO $ (mytracepp ("evalEIt POS " ++ showpp b) <$> isValid γ b)+  nb' <- liftIO $ (mytracepp ("evalEIt NEG " ++ showpp (PNot b)) <$> isValid γ (PNot b))+  if b' +    then return (e1, noExpand)+    else if nb' then return $ (e2, noExpand)+    else return $ (EIte b e1 e2, fe)++--------------------------------------------------------------------------------+-- | Knowledge (SMT Interaction)+--------------------------------------------------------------------------------+data Knowledge = KN +  { knSims              :: Map Symbol [Rewrite]   -- ^ Rewrites rules came from match and data type definitions +                                                  --   They are grouped by the data constructor that they unfold+  , knAms               :: Map Symbol Equation -- ^ All function definitions+  , knContext           :: SMT.Context+  , knPreds             :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool+  , knLams              :: ![(Symbol, Sort)]+  , knSummary           :: ![(Symbol, Int)]     -- ^ summary of functions to be evaluates (knSims and knAsms) with their arity+  , knDCs               :: !(S.HashSet Symbol)  -- ^ data constructors drawn from Rewrite +  , knSels              :: !SelectorMap +  , knConsts            :: !ConstDCMap+  , knAutoRWs           :: M.HashMap SubcId [AutoRewrite]+  , knRWTerminationOpts :: RWTerminationOpts+  }++isValid :: Knowledge -> Expr -> IO Bool+isValid γ e = do +  contra <- knPreds γ (knContext γ) (knLams γ) PFalse+  if contra +    then return False +    else knPreds γ (knContext γ) (knLams γ) e++knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge+knowledge cfg ctx si = KN +  { knSims                     = Map.fromListWith (++) [ (smDC rw, [rw]) | rw <- sims]+  , knAms                      = Map.fromList [(eqName eq, eq) | eq <- aenvEqs aenv]+  , knContext                  = ctx +  , knPreds                    = askSMT  cfg +  , knLams                     = [] +  , knSummary                  =    ((\s -> (smName s, 1)) <$> sims) +                                 ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)+                                 ++ rwSyms+  , knDCs                      = S.fromList (smDC <$> sims)+  , knSels                     = Mb.catMaybes $ map makeSel  sims +  , knConsts                   = Mb.catMaybes $ map makeCons sims +  , knAutoRWs                  = aenvAutoRW aenv+  , knRWTerminationOpts        =+      if (rwTerminationCheck cfg)+      then RWTerminationCheckEnabled+      else RWTerminationCheckDisabled+  } +  where +    sims = aenvSimpl aenv+    aenv = ae si++    inRewrites :: Symbol -> Bool+    inRewrites e =+      let+        syms = Mb.catMaybes $ map (lhsHead . arLHS) $ concat $ M.elems $ aenvAutoRW aenv+      in+        e `L.elem` syms++    lhsHead :: Expr -> Maybe Symbol+    lhsHead e | (EVar f, _) <- splitEApp e = Just f+    lhsHead _ | otherwise = Nothing+++    rwSyms = filter (inRewrites . fst) $ map toSum (toListSEnv (gLits si))+      where+        toSum (sym, sort)      = (sym, getArity sort)++        getArity (FFunc _ rhs) = 1 + getArity rhs+        getArity _             = 0++++    makeCons rw +      | null (syms $ smBody rw)+      = Just (smName rw, (smDC rw, smBody rw))+      | otherwise+      = Nothing ++    makeSel rw +      | EVar x <- smBody rw+      = (smName rw,) . (smDC rw,) <$> L.elemIndex x (smArgs rw)+      | otherwise +      = Nothing ++askSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool+askSMT cfg ctx bs e+--   | isContraPred e     = return False +  | isTautoPred  e     = return True+  | null (Vis.kvarsExpr e) = SMT.checkValidWithContext ctx [] PTrue e'+  | otherwise          = return False+  where +    e'                 = toSMT "askSMT" cfg ctx bs e ++toSMT :: String ->  Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred+toSMT msg cfg ctx bs e = defuncAny cfg senv . elaborate "makeKnowledge" (elabEnv bs) . mytracepp ("toSMT from " ++ msg ++ showpp e)+                          $ e +  where+    elabEnv      = insertsSymEnv senv+    senv         = SMT.ctxSymEnv ctx+++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++withCtx :: Config -> FilePath -> SymEnv -> (SMT.Context -> IO a) -> IO a+withCtx cfg file env k = do+  ctx <- SMT.makeContextWithSEnv cfg file env+  _   <- SMT.smtPush ctx+  res <- k ctx+  _   <- SMT.cleanupContext ctx+  return res+++-- (sel_i, D, i), meaning sel_i (D x1 .. xn) = xi, +-- i.e., sel_i selects the ith value for the data constructor D  +type SelectorMap = [(Symbol, (Symbol, Int))]+type ConstDCMap = [(Symbol, (Symbol, Expr))]++-- ValueMap maps expressions to constants (including data constructors)+type ConstMap = M.HashMap Expr Expr+type LDataCon = Symbol              -- Data Constructors ++isSimplification :: S.HashSet LDataCon -> (Expr,Expr) -> Bool +isSimplification dcs (_,c) = isConstant dcs c +  ++isConstant :: S.HashSet LDataCon -> Expr -> Bool +isConstant dcs e = S.null (S.difference (exprSymbolsSet e) dcs)++class Simplifiable a where +  simplify :: Knowledge -> ICtx -> a -> a +++instance Simplifiable Expr where+  simplify γ ictx e = mytracepp ("simplification of " ++ showpp e) $ fix (Vis.mapExprOnExpr tx) e+    where +      fix f e = if e == e' then e else fix f e' where e' = f e +      tx e +        | Just e' <- M.lookup e (icSimpl ictx)+        = e' +      tx (EBin bop e1 e2) = applyConstantFolding bop e1 e2+      tx (ENeg e)         = applyConstantFolding Minus (ECon (I 0)) e+      tx (EApp (EVar f) a)+        | Just (dc, c)  <- L.lookup f (knConsts γ) +        , (EVar dc', _) <- splitEApp a+        , dc == dc' +        = c+      tx (EIte b e1 e2)+        | isTautoPred b  = e1 +        | isContraPred b = e2+      tx (ECoerc s t e)+        | s == t = e +      tx (EApp (EVar f) a)+        | Just (dc, i)  <- L.lookup f (knSels γ) +        , (EVar dc', es) <- splitEApp a+        , dc == dc' +        = es!!i+      tx e = e+      +applyConstantFolding :: Bop -> Expr -> Expr -> Expr+applyConstantFolding bop e1 e2 =+  case (e1, e2) of+    ((ECon (R left)), (ECon (R right))) ->+      Mb.fromMaybe e (cfR bop left right)+    ((ECon (R left)), (ECon (I right))) ->+      Mb.fromMaybe e (cfR bop left (fromIntegral right))+    ((ECon (I left)), (ECon (R right))) ->+      Mb.fromMaybe e (cfR bop (fromIntegral left) right)+    ((ECon (I left)), (ECon (I right))) ->+      Mb.fromMaybe e (cfI bop left right)+    _ -> e+  where+    +    e = EBin bop e1 e2+    +    getOp :: Num a => Bop -> Maybe (a -> a -> a)+    getOp Minus    = Just (-)+    getOp Plus     = Just (+)+    getOp Times    = Just (*)+    getOp RTimes   = Just (*)+    getOp _        = Nothing++    cfR :: Bop -> Double -> Double -> Maybe Expr+    cfR bop left right = fmap go (getOp' bop)+      where+        go f = ECon $ R $ f left right+        +        getOp' Div      = Just (/)+        getOp' RDiv     = Just (/)+        getOp' op       = getOp op++    cfI :: Bop -> Integer -> Integer -> Maybe Expr+    cfI bop left right = fmap go (getOp' bop)+      where+        go f = ECon $ I $ f left right+        +        getOp' Mod = Just mod+        getOp' op  = getOp op+++-------------------------------------------------------------------------------+-- | Normalization of Equation: make their arguments unique -------------------+-------------------------------------------------------------------------------++class Normalizable a where +  normalize :: a -> a ++instance Normalizable (GInfo c a) where +  normalize si = si {ae = normalize $ ae si}++instance Normalizable AxiomEnv where +  normalize aenv = aenv { aenvEqs   = mytracepp "aenvEqs"  (normalize <$> aenvEqs   aenv)+                        , aenvSimpl = mytracepp "aenvSimpl" (normalize <$> aenvSimpl aenv) }++instance Normalizable Rewrite where +  normalize rw = rw { smArgs = xs', smBody = normalizeBody (smName rw) $ subst su $ smBody rw }+    where +      su  = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'+      xs  = smArgs rw +      xs' = zipWith mkSymbol xs [0..]+      mkSymbol x i = x `suffixSymbol` intSymbol (smName rw) i +++instance Normalizable Equation where +  normalize eq = eq {eqArgs = zip xs' ss, eqBody = normalizeBody (eqName eq) $ subst su $ eqBody eq }+    where +      su      = mkSubst $ zipWith (\x y -> (x,EVar y)) xs xs'+      (xs,ss) = unzip (eqArgs eq) +      xs'     = zipWith mkSymbol xs [0..]+      mkSymbol x i = x `suffixSymbol` intSymbol (eqName eq) i +++normalizeBody :: Symbol -> Expr -> Expr+normalizeBody f = go   +  where +    go e +      | any (== f) (syms e) +      = go' e +    go e +      = e +    +    go' (PAnd [PImp c e1,PImp (PNot c') e2])+      | c == c' = EIte c e1 (go' e2)+    go' e = e ++_splitBranches :: Symbol -> Expr -> [(Expr, Expr)]+_splitBranches f = go   +  where +    go (PAnd es) +      | any (== f) (syms es) +      = go' <$> es+    go e +      = [(PTrue, e)]++    go' (PImp c e) = (c, e) +    go' e          = (PTrue, e)++-- -- TODO:FUEL Config+-- maxFuel :: Int+-- maxFuel = 11 ++useFuel :: Symbol -> EvalST ()+useFuel f = do +  modify (\st -> st { evFuel = useFuelCount f (evFuel st) })++useFuelCount :: Symbol -> FuelCount -> FuelCount +useFuelCount f fc = fc { fcMap = M.insert f (k + 1) m }+  where +    k             = M.lookupDefault 0 f m +    m             = fcMap fc++checkFuel :: Symbol -> EvalST Bool+checkFuel f = do +  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
@@ -1,7 +1,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms            #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  -- | Functions to make environments easier to read module Language.Fixpoint.Solver.Prettify (savePrettifiedQuery) where@@ -9,10 +11,9 @@ import           Data.Bifunctor (first) import           Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap-import qualified Data.HashMap.Strict as M import           Data.HashSet (HashSet) import qualified Data.HashSet as HashSet-import           Data.List (group, intersperse, sortOn)+import           Data.List (intersperse, sortOn) import           Data.Maybe (fromMaybe) import           Data.Text (Text) import qualified Data.Text as Text@@ -22,7 +23,7 @@   , inlineInSortedReft   , mergeDuplicatedBindings   , simplifyBooleanRefts-  , undoANFAndVV+  , undoANF   ) import           Language.Fixpoint.Types.Config (Config, queryFile) import           Language.Fixpoint.Types.Constraints@@ -39,14 +40,10 @@   ) import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Refinements-  ( ExprBV(..)-  , pattern PFalse-  , pattern PKVar+  ( Expr(..)   , Reft-  , ReftBV(..)   , SortedReft(..)   , conjuncts-  , expr   , reft   , reftBind   , reftPred@@ -63,48 +60,40 @@   savePrettifiedQuery :: Fixpoint a => Config -> FInfo a -> IO ()-savePrettifiedQuery cfg info = do+savePrettifiedQuery cfg fi = do   let fq   = queryFile Files.Fq cfg `addExtension` "prettified"   putStrLn $ "Saving prettified Query: "   ++ fq ++ "\n"   ensurePath fq-  writeFile fq $ render (prettyConstraints info)+  writeFile fq $ render (prettyConstraints fi)  prettyConstraints :: Fixpoint a => FInfo a -> Doc-prettyConstraints info =+prettyConstraints fi =   vcat $-  map-    (prettyConstraint (bs info) . snd)-    (sortOn fst $ HashMap.toList (cm info))-  ++-  map-    (prettyWfConstraint (bs info) . snd)-    (sortOn fst $ HashMap.toList (ws info))+  map (prettyConstraint (bs fi)) $+  map snd $+  sortOn fst $+  HashMap.toList (cm fi)  prettyConstraint   :: Fixpoint a-  => BindEnv a+  => BindEnv   -> SubC a   -> Doc prettyConstraint bindEnv c =-  let env = [ (s, ([(bId, a)], sr))+  let env = [ (s, ([bId], sr))             | bId <- elemsIBindEnv $ senv c-            , let (s, sr, a) = lookupBindEnv bId bindEnv+            , let (s, sr) = lookupBindEnv bId bindEnv             ]       mergedEnv = mergeDuplicatedBindings env-      undoANFEnv = undoANFAndVV mergedEnv-      boolSimplEnvDiff = simplifyBooleanRefts undoANFEnv-      boolSimplEnv = HashMap.map snd $ HashMap.union boolSimplEnvDiff undoANFEnv+      undoANFEnv = HashMap.union (undoANF mergedEnv) mergedEnv+      boolSimplEnv = HashMap.union (simplifyBooleanRefts undoANFEnv) undoANFEnv -      simplifiedLhs = simplify $ inlineInSortedReft (`HashMap.lookup` boolSimplEnv) (slhs c)-      simplifiedRhs = simplify $ inlineInSortedReft (`HashMap.lookup` boolSimplEnv) (srhs c)+      simplifiedLhs = inlineInSortedReft boolSimplEnv (slhs c)+      simplifiedRhs = inlineInSortedReft boolSimplEnv (srhs c)        prunedEnv =-        if expr simplifiedRhs /= PFalse then-          dropLikelyIrrelevantBindings-            (constraintSymbols simplifiedLhs simplifiedRhs)-            boolSimplEnv-        else-          boolSimplEnv+        dropLikelyIrrelevantBindings (constraintSymbols simplifiedLhs simplifiedRhs) $+        HashMap.map snd boolSimplEnv       (renamedEnv, c') =         shortenVarNames prunedEnv c { slhs = simplifiedLhs, srhs = simplifiedRhs }       prettyEnv =@@ -138,29 +127,6 @@       , reftPred $ sr_reft sr       ) -prettyWfConstraint-  :: Fixpoint a-  => BindEnv a-  -> WfC a-  -> Doc-prettyWfConstraint bindEnv wfc =-  let prettyEnv =-        concatMap (take 1) $-        group $   -- eliminate duplicates-        sortOn fst-          [ (s, sr_sort sr)-          | bId <- elemsIBindEnv $ wenv wfc-          , let (s, sr, _a) = lookupBindEnv bId bindEnv-          ]-      (v, t, k) = wrft wfc-   in hang (text "\n\nwf:") 2 $-          hang (text "env:") 2-            (vcat $ map prettyBind prettyEnv)-      $+$ text "reft" <+> toFix (RR t (Reft (v, PKVar k M.empty mempty)))-      $+$ toFixMeta (text "wf") (toFix (winfo wfc))-  where-    prettyBind (s, srt) = toFix s <+> ":" <+> toFix srt- pprId :: Show a => Maybe a -> Doc pprId (Just i)  = "id" <+> text (show i) pprId _         = ""@@ -191,11 +157,11 @@   :: HashMap Symbol SortedReft   -> SubC a   -> ([(Symbol, SortedReft)], SubC a)-shortenVarNames env subc =+shortenVarNames env c =   let bindsRenameMap = proposeRenamings $ HashMap.keys env       env' = map (renameBind bindsRenameMap) (HashMap.toList env)    in-      (env', renameSubC bindsRenameMap subc)+      (env', renameSubC bindsRenameMap c)   where     renameSubC :: HashMap Symbol Symbol -> SubC a -> SubC a     renameSubC symMap c =@@ -215,16 +181,16 @@     renameSortedReft       :: HashMap Symbol Symbol -> SortedReft -> SortedReft     renameSortedReft symMap (RR t r) =-      let sortSubst = FObj . at symMap+      let sortSubst = FObj . (at symMap)        in RR (substSort sortSubst t) (renameReft symMap r)      renameReft :: HashMap Symbol Symbol -> Reft -> Reft     renameReft symMap r =       let m = HashMap.insert (reftBind r) (prefixOfSym $ reftBind r) symMap-          sortSubst = FObj . at symMap+          sortSubst = FObj . (at symMap)        in reft (at m (reftBind r)) $             substSortInExpr sortSubst $-            substf (EVar . at m) (reftPred r)+            (substf (EVar . (at m)) $ reftPred r)      at :: HashMap Symbol Symbol -> Symbol -> Symbol     at m k = fromMaybe k $ HashMap.lookup k m@@ -254,7 +220,7 @@ -- -- > forall ss. -- > Set.fromList ss == Set.fromList $ concat [ xs | m <- elems (toPrefixSuffixMap ss), xs <- elems m ]---+--  -- > forall ss. -- > and [ all (pfx `isPrefixOfSym`) xs && all (sfx `isSuffixOfSym`) xs -- >     | (pfx, m) <- toList (toPrefixSuffixMap ss)@@ -283,9 +249,9 @@       [(_sfx, ss)] -> renameWithAppendages pfx ("", ss)       sfxs -> concatMap (renameWithAppendages pfx) sfxs -    renameWithAppendages pfx (sfx, xs) = zip xs $ case xs of+    renameWithAppendages pfx (sfx, ss) = zip ss $ case ss of       [_s] -> [pfx `suffixIfNotNull` sfx]-      ss -> zipWith (rename pfx sfx) [1 :: Integer ..] ss+      ss -> zipWith (rename pfx sfx) [1..] ss      rename pfx sfx i _s =       pfx `suffixIfNotNull` sfx `suffixSymbol` symbol (show i)
src/Language/Fixpoint/Solver/Rewrite.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric             #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE PatternGuards             #-} {-# LANGUAGE ScopedTypeVariables       #-}  module Language.Fixpoint.Solver.Rewrite   ( getRewrite+  -- , getRewrite'   , subExprs   , unify   , ordConstraints@@ -15,33 +15,22 @@   , RWTerminationOpts(..)   , SubExpr   , TermOrigin(..)-  , OCType-  , RESTOrdering(..)   ) where -import           Control.Monad (guard)+import           Control.Monad.State import           Control.Monad.Trans.Maybe-import           Data.Hashable import qualified Data.HashMap.Strict  as M import qualified Data.List            as L import qualified Data.Text as TX import           GHC.IO.Handle.Types (Handle)-import           GHC.Generics import           Text.PrettyPrint (text)-import           Language.Fixpoint.Types.Config (RESTOrdering(..)) import           Language.Fixpoint.Types hiding (simplify)-import           Language.Fixpoint.Smt.Types (SmtM) import           Language.REST-import           Language.REST.KBO (kbo)-import           Language.REST.LPO (lpo)-import           Language.REST.OCAlgebra as OC-import           Language.REST.OCToAbstract (lift)-import           Language.REST.Op-import           Language.REST.SMT (SMTExpr)-import           Language.REST.WQOConstraints.ADT (ConstraintsADT, adtOC)+import           Language.REST.AbstractOC import qualified Language.REST.RuntimeTerm as RT+import           Language.REST.Op+import           Language.REST.OrderingConstraints.ADT (ConstraintsADT) --- | @(e, f)@ asserts that @e@ is a subexpression of @f e@ type SubExpr = (Expr, Expr -> Expr)  data TermOrigin = PLE | RW deriving (Show, Eq)@@ -55,46 +44,17 @@   | RWTerminationCheckDisabled  data RewriteArgs = RWArgs- { isRWValid          :: Expr -> SmtM Bool+ { isRWValid          :: Expr -> IO Bool  , rwTerminationOpts  :: RWTerminationOpts  } --- Monomorphize ordering constraints so we don't litter PLE with type variables--- Also helps since GHC doesn't support impredicate polymorphism (yet)-data OCType =-    RPO (ConstraintsADT Op)-  | LPO (ConstraintsADT Op)-  | KBO (SMTExpr Bool)-  | Fuel Int-  deriving (Eq, Show, Generic, Hashable)--ordConstraints :: RESTOrdering -> (Handle, Handle) -> OCAlgebra OCType RT.RuntimeTerm IO-ordConstraints RESTRPO      solver = bimapConstraints RPO asRPO (adtRPO solver)-  where-    asRPO (RPO t) = t-    asRPO _       = undefined--ordConstraints RESTKBO      solver = bimapConstraints KBO asKBO (kbo solver)-  where-    asKBO (KBO t) = t-    asKBO _       = undefined--ordConstraints RESTLPO      solver = bimapConstraints LPO asLPO (lift (adtOC solver) lpo)-  where-    asLPO (LPO t) = t-    asLPO _       = undefined--ordConstraints (RESTFuel m) _      = bimapConstraints Fuel asFuel $ fuelOC m-  where-    asFuel (Fuel n) = n-    asFuel _        = undefined+ordConstraints :: (Handle, Handle) -> AbstractOC (ConstraintsADT Op) Expr IO+ordConstraints solver = contramap convert (adtRPO solver)  --- Note: if you change the domain of this function, you need to change--- also Language.Fixpoint.Solver.PLE.isExprRewritable convert :: Expr -> RT.RuntimeTerm convert (EIte i t e)   = RT.App "$ite" $ map convert [i,t,e]-convert e@EApp{}       | (f, terms) <- splitEAppThroughECst e, EVar fName <- dropECst f+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 ]@@ -105,48 +65,37 @@ convert (ECon c)       = RT.App (Op $ "$econ" `TX.append` (TX.pack . show) c) [] convert (ESym (SL tx)) = RT.App (Op tx) [] convert (ECst t _)     = convert t-convert (PIff e0 e1)   = convert (PAtom Eq e0 e1)-convert (PImp e0 e1)   = convert (POr [PNot e0, e1]) convert e              = error (show e) -passesTerminationCheck :: OCAlgebra oc a IO -> RewriteArgs -> oc -> IO Bool+passesTerminationCheck :: AbstractOC oc a IO -> RewriteArgs -> oc -> IO Bool passesTerminationCheck aoc rwArgs c =   case rwTerminationOpts rwArgs of     RWTerminationCheckEnabled  -> isSat aoc c     RWTerminationCheckDisabled -> return True --- | Yields the result of rewriting an expression with an autorewrite equation.------ Yields nothing if:------  * The result of the rewrite is identical to the original expression---  * Any of the arguments of the autorewrite has a refinement type which is---    not satisfied in the current context.--- getRewrite ::-     OCAlgebra oc Expr IO+     AbstractOC oc Expr IO   -> RewriteArgs   -> oc   -> SubExpr   -> AutoRewrite-  -> MaybeT SmtM ((Expr, Expr), Expr, oc)+  -> 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'-        eqn = (subst su lhs, subE')     mapM_ (checkSubst su) exprs     return $ case rwTerminationOpts rwArgs of       RWTerminationCheckEnabled ->         let           c' = refine aoc c subE subE'         in-          (eqn, expr', c')-      RWTerminationCheckDisabled -> (eqn, expr', c)+          (expr', c')+      RWTerminationCheckDisabled -> (expr', c)   where-    check :: Expr -> MaybeT SmtM ()+    check :: Expr -> MaybeT IO ()     check e = do       valid <- MaybeT $ Just <$> isRWValid rwArgs e       guard valid@@ -156,7 +105,7 @@      checkSubst su (s, e) =       do-        let su' = catSubst su $ mkSubst [("VV", subst su (EVar s))]+        let su' = (catSubst su $ mkSubst [("VV", subst su (EVar s))])         -- liftIO $ printf "Substitute %s in %s\n" (show su') (show e)         check $ subst (catSubst su su') e @@ -178,7 +127,7 @@     lhs'' = map (\(e, f) -> (e, \e' -> EBin op (f e') rhs)) lhs'     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> EBin op lhs (f e'))) rhs'-+     subExprs' (PImp lhs rhs) = lhs'' ++ rhs''   where     lhs' = subExprs lhs@@ -187,16 +136,7 @@     lhs'' = map (\(e, f) -> (e, \e' -> PImp (f e') rhs)) lhs'     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> PImp lhs (f e'))) rhs'--subExprs' (PIff lhs rhs) = lhs'' ++ rhs''-  where-    lhs' = subExprs lhs-    rhs' = subExprs rhs-    lhs'' :: [SubExpr]-    lhs'' = map (\(e, f) -> (e, \e' -> PIff (f e') rhs)) lhs'-    rhs'' :: [SubExpr]-    rhs'' = map (\(e, f) -> (e, \e' -> PIff lhs (f e'))) rhs'-+     subExprs' (PAtom op lhs rhs) = lhs'' ++ rhs''   where     lhs' = subExprs lhs@@ -206,10 +146,10 @@     rhs'' :: [SubExpr]     rhs'' = map (\(e, f) -> (e, \e' -> PAtom op lhs (f e'))) rhs' -subExprs' e@EApp{} =-  if f == EVar "Language.Haskell.Liquid.ProofCombinators.===" ||-     f == EVar "Language.Haskell.Liquid.ProofCombinators.==." ||-     f == EVar "Language.Haskell.Liquid.ProofCombinators.?"+subExprs' e@(EApp{}) =+  if (f == EVar "Language.Haskell.Liquid.ProofCombinators.===" ||+      f == EVar "Language.Haskell.Liquid.ProofCombinators.==." ||+      f == EVar "Language.Haskell.Liquid.ProofCombinators.?")   then []   else concatMap replace indexedArgs     where@@ -217,40 +157,10 @@       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' (ECst e t) =-    [ (e', \subE -> ECst (toE subE) t) | (e', toE) <- subExprs' e ]--subExprs' (PAnd es) = [ (e, PAnd . f) | (e, f) <- subs es ]--subExprs' (POr es) = [ (e, POr . f) | (e, f) <- subs es ]--subExprs' (ELet x e1 e2) = e1'' ++ e2''-  where-    e1' = subExprs e1-    e2' = subExprs e2-    e1'' :: [SubExpr]-    e1'' = map (\(e, f) -> (e, \e' -> ELet x (f e') e2)) e1'-    e2'' :: [SubExpr]-    e2'' = map (\(e, f) -> (e, \e' -> ELet x e1 (f e'))) e2'+        return (subArg, \subArg' -> eApps f $ (take i es) ++ (toArg subArg'):(drop (i+1) es))  subExprs' _ = [] --- | Computes the subexpressions of a list of expressions.--- Each subexpression comes with a function that rebuilds the--- context in which the subexpression occurs.------ > and [ es == f e | (e, f) <- subs es ]----subs :: [Expr] -> [(Expr, Expr -> [Expr])]-subs [] = []-subs [x] = [ (s, \e -> [f e]) | (s, f) <- subExprs x ]-subs (x:xs) = [ (s, \e -> f e : xs) | (s, f) <- subExprs x ]-              ++-              [ (s, \e -> x : f e) | (s, f) <- subs xs ]-- unifyAll :: [Symbol] -> [Expr] -> [Expr] -> Maybe Subst unifyAll _ []     []               = Just (Su M.empty) unifyAll freeVars (template:xs) (seen:ys) =@@ -262,60 +172,50 @@     return $ Su (M.union s1 s2) unifyAll _ _ _ = undefined --- | @unify vs template e = Just su@ yields a substitution @su@--- such that subst su template == e------ Moreover, @su@ is constraint to only substitute variables in @vs@.------ Yields @Nothing@ if no substitution exists.--- unify :: [Symbol] -> Expr -> Expr -> Maybe Subst unify _ template seenExpr | template == seenExpr = Just (Su M.empty)-unify freeVars template seenExpr = case (dropECst template, seenExpr) of-  -- preserve seen casts if possible+unify freeVars template seenExpr = case (template, seenExpr) of   (EVar rwVar, _) | rwVar `elem` freeVars ->     return $ Su (M.singleton rwVar seenExpr)-  -- otherwise discard the seen casts-  (template', _) -> case (template', dropECst seenExpr) of-    (EVar lhs, EVar rhs) | removeModName lhs == removeModName rhs ->-                           Just (Su M.empty)-      where-        removeModName ts = go "" (symbolString ts) where-          go buf []         = buf-          go _   ('.':rest) = go [] rest-          go buf (x:xs)     = go (buf ++ [x]) xs-    (EApp templateF templateBody, EApp seenF seenBody) ->-      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-    (ENeg rw, ENeg seen) ->-      unify freeVars rw seen-    (EBin op rwLeft rwRight, EBin op' seenLeft seenRight) | op == op' ->-      unifyAll freeVars [rwLeft, rwRight] [seenLeft, seenRight]-    (EIte cond rwLeft rwRight, EIte seenCond seenLeft seenRight) ->-      unifyAll freeVars [cond, rwLeft, rwRight] [seenCond, seenLeft, seenRight]-    (ECst rw _, seen) ->-      unify freeVars rw seen-    (ETApp rw _, ETApp seen _) ->-      unify freeVars rw seen-    (ETAbs rw _, ETAbs seen _) ->-      unify freeVars rw seen-    (PAnd rw, PAnd seen ) ->-      unifyAll freeVars rw seen-    (POr rw, POr seen ) ->-      unifyAll freeVars rw seen-    (PNot rw, PNot seen) ->-      unify freeVars rw seen-    (PImp templateF templateBody, PImp seenF seenBody) ->-      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-    (PIff templateF templateBody, PIff seenF seenBody) ->-      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-    (PAtom rel templateF templateBody, PAtom rel' seenF seenBody) | rel == rel' ->-      unifyAll freeVars [templateF, templateBody] [seenF, seenBody]-    (PAll _ rw, PAll _ seen) ->-      unify freeVars rw seen-    (PExist _ rw, PExist _ seen) ->-      unify freeVars rw seen-    (ECoerc _ _ rw, ECoerc _ _ seen) ->-      unify freeVars rw seen-    (ELet _ rw1 rw2, ELet _ seen1 seen2) ->-      unifyAll freeVars [rw1, rw2] [seen1, seen2]-    _ -> Nothing+  (EVar lhs, EVar rhs) | removeModName lhs == removeModName rhs ->+                         Just (Su M.empty)+    where+      removeModName ts = go "" (symbolString ts) where+        go buf []         = buf+        go _   ('.':rest) = go [] rest+        go buf (x:xs)     = go (buf ++ [x]) xs+  (EApp templateF templateBody, EApp seenF seenBody) ->+    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+  (ENeg rw, ENeg seen) ->+    unify freeVars rw seen+  (EBin op rwLeft rwRight, EBin op' seenLeft seenRight) | op == op' ->+    unifyAll freeVars [rwLeft, rwRight] [seenLeft, seenRight]+  (EIte cond rwLeft rwRight, EIte seenCond seenLeft seenRight) ->+    unifyAll freeVars [cond, rwLeft, rwRight] [seenCond, seenLeft, seenRight]+  (ECst rw _, ECst seen _) ->+    unify freeVars rw seen+  (ETApp rw _, ETApp seen _) ->+    unify freeVars rw seen+  (ETAbs rw _, ETAbs seen _) ->+    unify freeVars rw seen+  (PAnd rw, PAnd seen ) ->+    unifyAll freeVars rw seen+  (POr rw, POr seen ) ->+    unifyAll freeVars rw seen+  (PNot rw, PNot seen) ->+    unify freeVars rw seen+  (PImp templateF templateBody, PImp seenF seenBody) ->+    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+  (PIff templateF templateBody, PIff seenF seenBody) ->+    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+  (PAtom rel templateF templateBody, PAtom rel' seenF seenBody) | rel == rel' ->+    unifyAll freeVars [templateF, templateBody] [seenF, seenBody]+  (PAll _ rw, PAll _ seen) ->+    unify freeVars rw seen+  (PExist _ rw, PExist _ seen) ->+    unify freeVars rw seen+  (PGrad _ _ _ rw, PGrad _ _ _ seen) ->+    unify freeVars rw seen+  (ECoerc _ _ rw, ECoerc _ _ seen) ->+    unify freeVars rw seen+  _ -> Nothing
src/Language/Fixpoint/Solver/Sanitize.hs view
@@ -2,6 +2,7 @@ --   1. Each binder must be associated with a UNIQUE sort {-# LANGUAGE TupleSections     #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards     #-}  module Language.Fixpoint.Solver.Sanitize   ( -- * Transform FInfo to enforce invariants@@ -15,44 +16,45 @@   ) where  import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Types.Visitor-import           Language.Fixpoint.SortCheck     (ElabParam(..), theoryEnv, elaborate, applySorts, isFirstOrder)--- import           Language.Fixpoint.Defunctionalize-import           Language.Fixpoint.Misc ((==>))+import           Language.Fixpoint.Types.Visitor +import           Language.Fixpoint.SortCheck     (elaborate, applySorts, isFirstOrder)+-- import           Language.Fixpoint.Defunctionalize  import qualified Language.Fixpoint.Misc                            as Misc import qualified Language.Fixpoint.Types                           as F-import           Language.Fixpoint.Types.Config (Config, solverFlags)-import qualified Language.Fixpoint.Types.Config as Cfg+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 import           Language.Fixpoint.Graph (kvEdges, CVertex (..))-import qualified Data.Bifunctor as Bifunctor (first) import qualified Data.HashMap.Strict                               as M import qualified Data.HashSet                                      as S import qualified Data.List                                         as L import qualified Data.Text                                         as T import           Data.Maybe          (isNothing, mapMaybe, fromMaybe) import           Control.Monad       ((>=>))-import           GHC.Stack           (HasCallStack)-import           Text.PrettyPrint.HughesPJ hiding ((<>))-import qualified Language.Fixpoint.SortCheck as SortCheck+import           Text.PrettyPrint.HughesPJ  type SanitizeM a = Either E.Error a  ---------------------------------------------------------------------------------sanitize :: (Show a) => Config -> F.SInfo a -> SanitizeM (F.SInfo a)+sanitize :: Config -> F.SInfo a -> SanitizeM (F.SInfo a) ---------------------------------------------------------------------------------sanitize cfg =       banIrregularData+sanitize cfg =    -- banIllScopedKvars+        --      Misc.fM dropAdtMeasures+        --      >=>+                     banIrregularData          >=> Misc.fM dropFuncSortedShadowedBinders          >=> Misc.fM sanitizeWfC          >=> Misc.fM replaceDeadKvars-         >=> Misc.fM (dropDeadSubsts . restrictKVarDomain cfg)+         >=> Misc.fM (dropDeadSubsts . restrictKVarDomain)          >=>         banMixedRhs-         >=>         banQualifFreeVars cfg-         >=>         banConstraintFreeVars cfg+         >=>         banQualifFreeVars+         >=>         banConstraintFreeVars          >=> Misc.fM addLiterals          >=> Misc.fM (eliminateEta cfg)+         >=> Misc.fM cancelCoercion + -------------------------------------------------------------------------------- -- | 'dropAdtMeasures' removes all the measure definitions that correspond to --   constructor, selector or test names for declared datatypes, as these are@@ -82,19 +84,59 @@   where     lits'      = M.fromList [ (F.symbol x, F.strSort) | x <- symConsts si ] +++cancelCoercion :: F.SInfo a -> F.SInfo a+cancelCoercion = mapExpr (trans (defaultVisitor { txExpr = go }) () ())+  where +    go _ (F.ECoerc t1 t2 (F.ECoerc t2' t1' e)) +      | t1 == t1' && t2 == t2'+      = e +    go _ e = e + -------------------------------------------------------------------------------- -- | `eliminateEta` converts equations of the form f x = g x into f = g -------------------------------------------------------------------------------- eliminateEta :: Config -> F.SInfo a -> F.SInfo a -------------------------------------------------------------------------------- eliminateEta cfg si-  | Cfg.etaElim cfg+  | Cfg.etaElim cfg +  , Cfg.oldPLE  cfg+  = si { F.ae = ae' }+  | Cfg.etaElim cfg    = si { F.ae = (ae {F.aenvEqs = etaElimNEW `fmap` F.aenvEqs ae }) }-  | otherwise-  = si+  | otherwise +  = si    where+    ae' = ae {F.aenvEqs = eqs}     ae = F.ae si+    eqs = fmap etaElim (F.aenvEqs ae) +    etaElim eq = F.notracepp "Eliminating" $+                 case body of+                   F.PAtom F.Eq e0 e1 ->+                     let (f0, args0) = fapp e0+                         (f1, args1) = F.notracepp "f1" $ fapp e1 in+                     if reverse args0 == args+                     then let commonArgs = F.notracepp "commonArgs" .+                                           fmap fst .+                                           takeWhile (uncurry (==)) $+                                           zip args0 args1+                              commonLength = length commonArgs+                              (newArgsAndSorts, elimedArgsAndSorts) =+                                splitAt (length args - commonLength) argsAndSorts+                              args0' = F.eVar <$> reverse (drop commonLength args0)+                              args1' = F.eVar <$> reverse (drop commonLength args1) in+                       eq { F.eqArgs = newArgsAndSorts+                          , F.eqSort = foldr F.FFunc sort+                                       (snd <$> elimedArgsAndSorts)+                          , F.eqBody = F.PAtom F.Eq (F.eApps f0 args0') (F.eApps f1 args1')}+                     else eq+                   _ -> eq+      where argsAndSorts = F.eqArgs eq+            args = fst <$> argsAndSorts+            body = F.eqBody eq+            sort = F.eqSort eq     etaElimNEW eq = F.notracepp "Eliminating" $                   let (f1, args1) = fapp (F.eqBody eq) in                   let commonArgs = F.notracepp "commonArgs" .@@ -111,27 +153,26 @@                      , F.eqBody = F.eApps f1 args1'}       where argsAndSorts = F.eqArgs eq             args  = fst <$> argsAndSorts-            args0 = reverse args+            args0 = reverse args              sort  = F.eqSort eq-+                 fapp :: F.Expr -> (F.Expr, [F.Symbol])     fapp ee = fromMaybe (ee, []) (fapp' ee)-+         fapp' :: F.Expr -> Maybe (F.Expr, [F.Symbol])     fapp' (F.EApp e0 (F.EVar arg)) = do       (fvar, args) <- fapp' e0       splitApp (fvar, arg:args)     fapp' e = pure (e, []) -    thySyms = theoryEnv cfg si+    theorySymbols = F.notracepp "theorySymbols" $ Thy.theorySymbols $ F.ddecls si      splitApp (e, es)-      | isNothing $ F.notracepp ("isSmt2App? " ++ showpp e) $ Thy.isSmt2App thySyms (stripCasts e)+      | isNothing $ F.notracepp ("isSmt2App? " ++ showpp e) $ Thy.isSmt2App theorySymbols $ stripCasts e       = pure (e,es)       | otherwise       = Nothing - -------------------------------------------------------------------------------- -- | See issue liquid-fixpoint issue #230. This checks that whenever we have, --      G1        |- K.su1@@ -189,7 +230,7 @@ -- | `dropDeadSubsts` removes dead `K[x := e]` where `x` NOT in the domain of K. -------------------------------------------------------------------------------- dropDeadSubsts :: F.SInfo a -> F.SInfo a-dropDeadSubsts si = mapKVarSubsts (\k su -> F.toKVarSubst $ M.filterWithKey (f k) $ F.fromKVarSubst su) si+dropDeadSubsts si = mapKVarSubsts (F.filterSubst . f) si   where     kvsM          = M.mapWithKey (\k _ -> kvDom k) (F.ws si)     kvDom         = S.fromList . F.kvarDomain si@@ -201,12 +242,10 @@ --   `x` which appear in substitutions of the form `K[x := y]` where `y` --   is not in the env. ---------------------------------------------------------------------------------restrictKVarDomain :: Config -> F.SInfo a -> F.SInfo a-restrictKVarDomain cfg si-  | Cfg.explicitKvars cfg = si-  | otherwise             = si { F.ws = M.mapWithKey (restrictWf kvm) (F.ws si) }+restrictKVarDomain :: F.SInfo a -> F.SInfo a+restrictKVarDomain si = si { F.ws = M.mapWithKey (restrictWf kvm) (F.ws si) }   where-    kvm                   = safeKvarEnv si+    kvm               = safeKvarEnv si  -- | `restrictWf kve k w` restricts the env of `w` to the parameters in `kve k`. restrictWf :: KvDom -> F.KVar -> F.WfC a -> F.WfC a@@ -216,21 +255,20 @@     kis            = S.fromList [ i | (_, i) <- F.toListSEnv kEnv ]     kEnv           = M.lookupDefault mempty k kve -type KvDom     = M.HashMap F.KVar (F.SEnv F.BindId)-type KvBads    = M.HashMap F.KVar [F.Symbol]- -- | `safeKvarEnv` computes the "real" domain of each kvar, which is --   a SUBSET of the input domain, in which we KILL the parameters --   `x` which appear in substitutions of the form `K[x := y]` --   where `y` is not in the env. +type KvDom     = M.HashMap F.KVar (F.SEnv F.BindId)+type KvBads    = M.HashMap F.KVar [F.Symbol]+ safeKvarEnv :: F.SInfo a -> KvDom safeKvarEnv si = L.foldl' (dropKvarEnv si) env0 cs   where     cs         = M.elems  (F.cm si)     env0       = initKvarEnv si - dropKvarEnv :: F.SInfo a -> KvDom -> F.SimpC a -> KvDom dropKvarEnv si kve c = M.mapWithKey (dropBadParams kBads) kve   where@@ -244,9 +282,9 @@ badParams :: F.SInfo a -> F.SimpC a -> M.HashMap F.KVar [F.Symbol] badParams si c = Misc.group bads   where-    bads       = [ (k, x) | (v, k, su) <- subcKSubs xsrs c+    bads       = [ (k, x) | (v, k, F.Su su) <- subcKSubs xsrs c                           , let vEnv = maybe sEnv (`S.insert` sEnv) v-                          , (x, e)          <- M.toList (F.fromKVarSubst su)+                          , (x, e)          <- M.toList su                           , badArg vEnv e                  ]     sEnv       = S.fromList (fst <$> xsrs)@@ -256,16 +294,16 @@ badArg sEnv (F.EVar y) = not (y `S.member` sEnv) badArg _    _          = True -type KSub = (Maybe F.Symbol, F.KVar, F.KVarSubst F.Symbol F.Symbol)+type KSub = (Maybe F.Symbol, F.KVar, F.Subst)  subcKSubs :: [(F.Symbol, F.SortedReft)] -> F.SimpC a -> [KSub] subcKSubs xsrs c = rhs ++ lhs   where     lhs          = [ (Just v, k, su) | (_, sr) <- xsrs                                      , let rs   = F.reftConjuncts (F.sr_reft sr)-                                     , F.Reft (v, F.PKVar k _ su) <- rs+                                     , F.Reft (v, F.PKVar k su) <- rs                    ]-    rhs          = [(Nothing, k, su) | F.PKVar k _ su <- [F.crhs c]]+    rhs          = [(Nothing, k, su) | F.PKVar k su <- [F.crhs c]]   initKvarEnv :: F.SInfo a -> KvDom@@ -275,38 +313,36 @@ initEnv si w = F.fromListSEnv [ (bind i, i) | i <- is ]   where     is       = F.elemsIBindEnv $ F.wenv w-    bind i   = Misc.fst3 (F.lookupBindEnv i be)+    bind i   = fst (F.lookupBindEnv i be)     be       = F.bs si  -------------------------------------------------------------------------------- -- | check that no constraint has free variables (ignores kvars) ---------------------------------------------------------------------------------banConstraintFreeVars :: Config -> F.SInfo a -> SanitizeM (F.SInfo a)-banConstraintFreeVars cfg fi0 = Misc.applyNonNull (Right fi0) (Left . badCs) bads+banConstraintFreeVars :: F.SInfo a -> SanitizeM (F.SInfo a)+banConstraintFreeVars fi0 = Misc.applyNonNull (Right fi0) (Left . badCs) bads   where     fi      = mapKVars (const $ Just F.PTrue) fi0     bads    = [(c, fs) | c <- M.elems $ F.cm fi, Just fs <- [cNoFreeVars fi k c]]-    k       = known cfg fi+    k       = known fi -known :: Config -> F.SInfo a -> F.Symbol -> Bool-known cfg fi  = \x -> F.memberSEnv x lits || F.memberSEnv x prims+known :: F.SInfo a -> F.Symbol -> Bool+known fi  = \x -> F.memberSEnv x lits || F.memberSEnv x prims   where     lits  = F.gLits fi-    prims = theoryEnv cfg fi-+    prims = Thy.theorySymbols . F.ddecls $ fi  cNoFreeVars :: F.SInfo a -> (F.Symbol -> Bool) -> F.SimpC a -> Maybe [F.Symbol]-cNoFreeVars fi knownSym c = if S.null fv then Nothing else Just (S.toList fv)+cNoFreeVars fi known c = if S.null fv then Nothing else Just (S.toList fv)   where     be   = F.bs fi     ids  = F.elemsIBindEnv $ F.senv c-    cDom = [Misc.fst3 $ F.lookupBindEnv i be | i <- ids]-    cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . Misc.snd3 $ F.lookupBindEnv i be | i <- ids]-        ++ F.syms (F.crhs c)-    fv   = (`Misc.nubDiff` cDom) . filter (not . knownSym) $ cRng+    cDom = [fst $ F.lookupBindEnv i be | i <- ids]+    cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . snd $ F.lookupBindEnv i be | i <- ids]+    fv   = (`Misc.nubDiff` cDom) . filter (not . known) $ cRng   badCs :: Misc.ListNE (F.SimpC a, [F.Symbol]) -> E.Error-badCs = E.catErrors . map (E.errFreeVarInConstraint . Bifunctor.first F.subcId)+badCs = E.catErrors . map (E.errFreeVarInConstraint . Misc.mapFst F.subcId)  -------------------------------------------------------------------------------- -- | check that every DataDecl is regular@@ -314,7 +350,7 @@ banIrregularData :: F.SInfo a -> SanitizeM (F.SInfo a) banIrregularData fi = Misc.applyNonNull (Right fi) (Left . badDataDecl) bads   where-    bads = F.checkRegular (F.ddecls fi )+    bads = F.checkRegular (F.ddecls fi )   badDataDecl :: Misc.ListNE F.DataDecl -> E.Error badDataDecl ds = E.catErrors [ E.errBadDataDecl d | d <- ds ]@@ -322,13 +358,15 @@ -------------------------------------------------------------------------------- -- | check that no qualifier has free variables ---------------------------------------------------------------------------------banQualifFreeVars :: Config -> F.SInfo a -> SanitizeM (F.SInfo a)+banQualifFreeVars :: F.SInfo a -> SanitizeM (F.SInfo a) ---------------------------------------------------------------------------------banQualifFreeVars cfg fi = Misc.applyNonNull (Right fi) (Left . badQuals) bads+banQualifFreeVars fi = Misc.applyNonNull (Right fi) (Left . badQuals) bads   where     bads    = [ (q, xs) | q <- F.quals fi, let xs = free q, not (null xs) ]-    free q  = filter (not . isGlobal) (F.syms q)-    isGlobal x = F.memberSEnv x (SortCheck.globalEnv cfg fi)+    free q  = filter (not . isLit) (F.syms q) +    isLit x = F.memberSEnv x (F.gLits fi) +    -- lits    = fst <$> F.toListSEnv (F.gLits fi)+    -- free q  = S.toList $ F.syms (F.qBody q) `nubDiff` (lits ++ F.prims ++ F.syms (F.qpSym <$> F.qParams q))  badQuals     :: Misc.ListNE (F.Qualifier, Misc.ListNE F.Symbol) -> E.Error badQuals bqs = E.catErrors [ E.errFreeVarInQual q xs | (q, xs) <- bqs]@@ -356,29 +394,28 @@ -- | symbol |-> sort for EVERY variable in the SInfo; 'symbolEnv' can ONLY be --   called with **sanitized** environments (post the uniqification etc.) or --   else you get duplicate sorts and other such errors.---   We do this peculiar dance with `env0` to extract the apply-sorts from the---   function definitions inside the `AxiomEnv` which cannot be elaborated as+--   We do this peculiar dance with `env0` to extract the apply-sorts from the +--   function definitions inside the `AxiomEnv` which cannot be elaborated as  --   it makes it hard to actually find the fundefs within (breaking PLE.) ---------------------------------------------------------------------------------symbolEnv :: HasCallStack => Config -> F.SInfo a -> F.SymEnv-symbolEnv cfg si = F.symEnv cfg sEnv thyEnv ds lits (ts ++ ts')+symbolEnv :: Config -> F.SInfo a -> F.SymEnv+symbolEnv cfg si = F.symEnv sEnv tEnv ds lits (ts ++ ts')   where-    ts'          = applySorts ae'-    ae'          = elaborate (ElabParam ef (F.atLoc E.dummySpan "symbolEnv") env0) (F.ae si)-    env0         = F.symEnv cfg sEnv thyEnv ds lits ts-    thyEnv       = theoryEnv cfg si+    ts'          = applySorts ae' +    ae'          = elaborate (F.atLoc E.dummySpan "symbolEnv") env0 (F.ae si)+    env0         = F.symEnv sEnv tEnv ds lits ts+    tEnv         = Thy.theorySymbols ds     ds           = F.ddecls si-    ts           = Misc.setNub (applySorts si ++ [t | (_, t) <- F.toListSEnv sEnv])-    sEnv         = F.coerceSortEnv ef $ (F.tsSort <$> thyEnv) `mappend` F.fromListSEnv xts-    ef           = solverFlags cfg+    ts           = Misc.hashNub (applySorts si ++ [t | (_, t) <- F.toListSEnv sEnv])+    sEnv         = (F.tsSort <$> tEnv) `mappend` (F.fromListSEnv xts)     xts          = symbolSorts cfg si ++ alits     lits         = F.dLits si `F.unionSEnv'` F.fromListSEnv alits     alits        = litsAEnv $ F.ae si  litsAEnv :: F.AxiomEnv -> [(F.Symbol, F.Sort)]-litsAEnv ae = zip (F.symbol <$> symConsts ae) (repeat F.strSort)+litsAEnv ae = zip (F.symbol <$> (symConsts ae)) (repeat $ F.strSort) -symbolSorts :: HasCallStack => Config -> F.GInfo c a -> [(F.Symbol, F.Sort)]+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)]@@ -387,16 +424,17 @@     normalize       = fmap (map (unShadow txFun dm))     dm              = M.fromList defs     defs            = F.toListSEnv . F.gLits $ fi-    txFun           = id+    txFun+      | True        = id  unShadow :: (F.Sort -> F.Sort) -> M.HashMap F.Symbol a -> (F.Symbol, F.Sort) -> (F.Symbol, F.Sort) unShadow tx dm (x, t)-  | M.member x dm = (x, t)-  | otherwise     = (x, tx t)+  | M.member x dm  = (x, t)+  | otherwise      = (x, tx t)  _defuncSort :: F.Sort -> F.Sort-_defuncSort F.FFunc{} = F.funcSort-_defuncSort t         = t+_defuncSort (F.FFunc {}) = F.funcSort+_defuncSort t            = t  compact :: [(F.Symbol, F.Sort)] -> Either E.Error [(F.Symbol, F.Sort)] compact xts@@ -428,7 +466,7 @@                                          , nest 4 (pprint y) ]  ---------------------------------------------------------------------------------symBinds  :: F.BindEnv a -> [SymBinds]+symBinds  :: F.BindEnv -> [SymBinds] -------------------------------------------------------------------------------- symBinds  = {- THIS KILLS ELEM: tracepp "symBinds" . -}             M.toList@@ -438,8 +476,8 @@  type SymBinds = (F.Symbol, [(F.Sort, [F.BindId])]) -binders :: F.BindEnv a -> [(F.Symbol, (F.Sort, F.BindId))]-binders be = [(x, (F.sr_sort t, i)) | (i, (x, t, _)) <- F.bindEnvToList be]+binders :: F.BindEnv -> [(F.Symbol, (F.Sort, F.BindId))]+binders be = [(x, (F.sr_sort t, i)) | (i, x, t) <- F.bindEnvToList be]   --------------------------------------------------------------------------------@@ -449,9 +487,12 @@ -------------------------------------------------------------------------------- dropFuncSortedShadowedBinders fi = dropBinders ok (const True) fi   where-    ok x t  = M.member x defs ==> (F.allowHO fi || isFirstOrder t)+    ok x t  = (M.member x defs) ==> (F.allowHO fi || isFirstOrder t)     defs    = M.fromList $ F.toListSEnv $ F.gLits fi +(==>) :: Bool -> Bool -> Bool+p ==> q = not p || q+ -------------------------------------------------------------------------------- -- | Drop irrelevant binders from WfC Environments --------------------------------------------------------------------------------@@ -461,6 +502,7 @@     ws'        = deleteWfCBinds drops <$> F.ws si     (_,drops)  = filterBindEnv keepF   $  F.bs si     keepF      = conjKF [nonConstantF si, nonFunctionF si, _nonDerivedLH]+    -- drops   = F.tracepp "sanitizeWfC: dropping" $ L.sort drops'  conjKF :: [KeepBindF] -> KeepBindF conjKF fs x t = and [f x t | f <- fs]@@ -508,13 +550,12 @@ deleteWfCBinds :: [F.BindId] -> F.WfC a -> F.WfC a deleteWfCBinds bs wf = wf { F.wenv = foldr F.deleteIBindEnv (F.wenv wf) bs } -filterBindEnv :: KeepBindF -> F.BindEnv a -> (F.BindEnv a, [F.BindId])-filterBindEnv f be  = (keepBindEnv , discard')+filterBindEnv :: KeepBindF -> F.BindEnv -> (F.BindEnv, [F.BindId])+filterBindEnv f be  = (F.bindEnvFromList keep, discard')   where-    keepBindEnv     = F.bindEnvFromList [(i, (x, sr, a)) | (i, (x, sr, a)) <- keep]     (keep, discard) = L.partition f' $ F.bindEnvToList be-    discard'        = fst <$> discard-    f' (_, (x, t, _)) = f x (F.sr_sort t)+    discard'        = Misc.fst3     <$> discard+    f' (_, x, t)    = f x (F.sr_sort t)   ---------------------------------------------------------------------------
− src/Language/Fixpoint/Solver/Simplify.hs 
@@ -1,165 +0,0 @@------------------------------------------------------------------------------------ | This module contains common functions used in the implementations of---     Simplifiable Expr in both Interpreter.hs and PLE.hs.-----------------------------------------------------------------------------------{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ViewPatterns              #-}--module Language.Fixpoint.Solver.Simplify (applyBooleanFolding, applyConstantFolding, applySetFolding, isSetPred) where--import           Language.Fixpoint.Types hiding (simplify)-import           Language.Fixpoint.Smt.Theories-import           Data.Hashable-import qualified Data.HashSet         as S-import qualified Data.Maybe           as Mb---applyBooleanFolding :: Brel -> Expr -> Expr -> Expr-applyBooleanFolding brel' e1 e2 =-  case (e1, e2) of-    (ECon (R left), ECon (R right)) ->-      Mb.fromMaybe e (bfR brel' left right)-    (ECon (R left), ECon (I right)) ->-      Mb.fromMaybe e (bfR brel' left (fromIntegral right))-    (ECon (I left), ECon (R right)) ->-      Mb.fromMaybe e (bfR brel' (fromIntegral left) right)-    (ECon (I left), ECon (I right)) ->-      Mb.fromMaybe e (bfI brel' left right)-    _ -> if isTautoPred e then PTrue else-           if isContraPred e then PFalse else e-  where-    e = PAtom brel' e1 e2--    getOp :: Ord a => Brel -> (a -> a -> Bool)-    getOp Gt   =  (>)-    getOp Ge   =  (>=)-    getOp Lt   =  (<)-    getOp Le   =  (<=)-    getOp Eq   =  (==)-    getOp Ne   =  (/=)-    getOp Ueq  =  (==)-    getOp Une  =  (/=)--    bfR :: Brel -> Double -> Double -> Maybe Expr-    bfR brel left right = if getOp brel left right then Just PTrue else Just PFalse--    bfI :: Brel -> Integer -> Integer -> Maybe Expr-    bfI brel left right = if getOp brel left right then Just PTrue else Just PFalse----- | Replace constant integer and floating point expressions by constant values--- where possible.-applyConstantFolding :: Bop -> Expr -> Expr -> Expr-applyConstantFolding bop' e1 e2 =-  case (dropECst e1, dropECst e2) of-    (ECon (R left), ECon (R right)) ->-      Mb.fromMaybe e (cfR bop' left right)-    (ECon (R left), ECon (I right)) ->-      Mb.fromMaybe e (cfR bop' left (fromIntegral right))-    (ECon (I left), ECon (R right)) ->-      Mb.fromMaybe e (cfR bop' (fromIntegral left) right)-    (ECon (I left), ECon (I right)) ->-      Mb.fromMaybe e (cfI bop' left right)-    (EBin Mod  _   _              , _)  -> e-    (EBin bop1 e11 (dropECst -> ECon (R left)), ECon (R right))-      | bop' == bop1 -> maybe e (EBin bop' e11) (cfR (rop bop') left right)-      | otherwise   -> e-    (EBin bop1 e11 (dropECst -> ECon (R left)), ECon (I right))-      | bop' == bop1 -> maybe e (EBin bop' e11) (cfR (rop bop') left (fromIntegral right))-      | otherwise   -> e-    (EBin bop1 e11 (dropECst -> ECon (I left)), ECon (R right))-      | bop' == bop1 -> maybe e (EBin bop' e11) (cfR (rop bop') (fromIntegral left) right)-      | otherwise   -> e-    (EBin bop1 e11 (dropECst -> ECon (I left)), ECon (I right))-      | bop' == bop1 -> maybe e (EBin bop' e11) (cfI (rop bop') left right)-      | otherwise   -> e-    _ -> e-  where--    rop :: Bop -> Bop-    rop Plus   = Plus-    rop Minus  = Plus-    rop Times  = Times-    rop Div    = Times-    rop RTimes = RTimes-    rop RDiv   = RTimes-    rop Mod    = Mod--    e = EBin bop' e1 e2--    getOp :: Num a => Bop -> Maybe (a -> a -> a)-    getOp Minus    = Just (-)-    getOp Plus     = Just (+)-    getOp Times    = Just (*)-    getOp RTimes   = Just (*)-    getOp _        = Nothing--    cfR :: Bop -> Double -> Double -> Maybe Expr-    cfR bop left right = go (getOp' bop)-      where-        go (Just f) =-          let x = f left right-           in if isNaN x || isInfinite x then Just $ ECon (R x)-              else Nothing-        go Nothing = Nothing--        getOp' Div  | right /= 0 = Just (/)-        getOp' RDiv | right /= 0 = 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 | right /= 0 = Just mod-        getOp' op  = getOp op--isSetPred :: Expr -> Bool-isSetPred (EVar s) | s == setEmp          = True-isSetPred (EApp e1 _) = case e1 of-  (EVar s) | s == setMem || s == setSub  -> True-  _                                      -> False-isSetPred _                               = False---- Note: this is currently limited to sets of integer constants-applySetFolding :: Expr -> Expr -> Expr-applySetFolding expr1 expr2   = case expr1 of-    (EVar s) | s == setEmp-      -> maybe e (fromBool . S.null) (evalSetI expr2)-    (EApp (EVar s) e1') | s == setMem-      -> maybe e fromBool (S.member <$> getInt e1' <*> evalSetI expr2)-                        | s == setEmp-      -> maybe e (fromBool . S.null) (S.difference <$> evalSetI e1' <*> evalSetI expr2)-                        | otherwise-      -> e-    _                   -> e-  where-    e = EApp expr1 expr2--    fromBool True  = PTrue-    fromBool False = PFalse--    getInt :: Expr -> Maybe Integer-    getInt (ECon (I n)) = Just n-    getInt _            = Nothing--    getOp :: (Eq a, Hashable a) => Symbol -> Maybe (S.HashSet a -> S.HashSet a -> S.HashSet a)-    getOp s | s == setCup = Just S.union-            | s == setCap = Just S.intersection-            | s == setDif = Just S.difference-            | otherwise   = Nothing--    evalSetI :: Expr -> Maybe (S.HashSet Integer)-    evalSetI (EApp e1 e2) = case e1 of-      (EVar s) | s == setEmpty -> Just S.empty-               | s == setSng   -> case e2 of-        (ECon (I n))             -> Just $ S.singleton n-        _                        -> Nothing-      (EApp (EVar f) e1')  -> getOp f <*> evalSetI e1' <*> evalSetI e2-      _                    -> Nothing-    evalSetI _            = Nothing-
src/Language/Fixpoint/Solver/Solution.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP               #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE PatternGuards     #-}  module Language.Fixpoint.Solver.Solution   ( -- * Create Initial Solution@@ -11,68 +11,60 @@     -- * Update Solution   , Sol.update -    -- * Apply Solution-  , applyInSortedReft-  , CombinedEnv(..)-  , qbPreds--    -- * Lookup Solution+  -- * Lookup Solution   , lhsPred    , nonCutsResult--    -- * Save Solution-  , saveSolution--    -- * Exported for Testing-  , simplifyKVar-  , alphaEq   ) where +import           Control.Parallel.Strategies import           Control.Arrow (second, (***))-import           Control.Monad                  (guard, mplus, when)-import           Control.Monad.Reader import qualified Data.HashSet                   as S import qualified Data.HashMap.Strict            as M-import qualified Data.List                      as List-import           Data.Maybe                     (maybeToList, isJust, isNothing)-import qualified Text.PrettyPrint.HughesPJ      as PJ+import qualified Data.List                      as L+import           Data.Maybe                     (fromMaybe, maybeToList, isNothing)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup                 (Semigroup (..))+#endif+ import           Language.Fixpoint.Types.PrettyPrint () import           Language.Fixpoint.Types.Visitor      as V-import           Language.Fixpoint.SortCheck          (ElabM) import qualified Language.Fixpoint.SortCheck          as So-import           Language.Fixpoint.Misc               (ensurePath) import qualified Language.Fixpoint.Misc               as Misc-import qualified Language.Fixpoint.Utils.Files        as Files import           Language.Fixpoint.Types.Config import qualified Language.Fixpoint.Types              as F+import           Language.Fixpoint.Types                 ((&.&)) import qualified Language.Fixpoint.Types.Solutions    as Sol import           Language.Fixpoint.Types.Constraints  hiding (ws, bs) import           Prelude                              hiding (init, lookup)+import           Language.Fixpoint.Solver.Sanitize +-- DEBUG+import Text.Printf (printf)+-- import Debug.Trace (trace) + -------------------------------------------------------------------------------- -- | Initial Solution (from Qualifiers and WF constraints) --------------------- ---------------------------------------------------------------------------------init :: (F.Fixpoint a) => Config -> F.SInfo a -> S.HashSet F.KVar -> M.HashMap F.KVar Sol.QBind+init :: (F.Fixpoint a) => Config -> F.SInfo a -> S.HashSet F.KVar -> Sol.Solution ---------------------------------------------------------------------------------init cfg si ks =-    runReader (traverse (refine si qcs genv) ws) (solverFlags cfg)-  where-    qcs = mkQCluster (F.quals si)-    ws = M.intersection (F.ws si) (S.toMap ks)-    genv = initQualifierEnv cfg si--initQualifierEnv :: (F.Fixpoint a) => Config -> F.SInfo a -> F.SEnv F.Sort-initQualifierEnv cfg si-  | scraping  = So.globalEnv cfg si <> instConstants si-  | otherwise = instConstants si+init cfg si ks_ = Sol.fromList senv mempty keqs [] mempty ebs xEnv   where-    scraping = scrape cfg /= No+    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)]  -------------------------------------------------------------------------------- -- | [NOTE:qual-cluster] It is wasteful to perform instantiation *individually*---   on each qualifier, as many qualifiers have "equivalent" parameters, and+--   on each qualifier, as many qualifiers have "equivalent" parameters, and  --   so have the "same" instances in an environment. To exploit this structure, -- --   1. Group the [Qualifier] into a QCluster@@ -87,16 +79,15 @@ mkQCluster = Misc.groupMap qualSig  qualSig :: Qualifier -> QCSig-qualSig q = [ p { F.qpSym = F.dummyName }  | p <- F.qParams q ]+qualSig q = [ p { F.qpSym = F.dummyName }  | p <- F.qParams q ]   -------------------------------------------------------------------------------- -refine :: F.SInfo a -> QCluster -> F.SEnv F.Sort -> F.WfC a -> ElabM Sol.QBind-refine info qs genv w = refineK (allowHOquals info) env lits qs (F.wrft w)+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             = wenvSort <> genv-    wenvSort        = F.sr_sort <$> F.fromListSEnv (F.envCs (F.bs info) (F.wenv w))-    lits            = getConstants info+    env             = wenv <> genv+    wenv            = F.sr_sort <$> F.fromListSEnv (F.envCs (F.bs fi) (F.wenv w))  instConstants :: F.SInfo a -> F.SEnv F.Sort instConstants = F.fromListSEnv . filter notLit . F.toListSEnv . F.gLits@@ -104,43 +95,28 @@     notLit    = not . F.isLitSymbol . fst  -refineK :: Bool -> F.SEnv F.Sort -> [F.Constant] -> QCluster -> (F.Symbol, F.Sort, F.KVar) -> ElabM Sol.QBind-refineK ho env lits qs (v, t, _k) = Sol.qbFilterM (okInst env v t) eqs+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 lits v t qs+    eqs                     = instK ho env v t qs+    eqs'                    = Sol.qbFilter (okInst env v t) eqs+    _msg                    = printf "\n\nrefineK: k = %s, eqs = %s" (F.showpp k) (F.showpp eqs)  -------------------------------------------------------------------------------- instK :: Bool       -> F.SEnv F.Sort-      -> [F.Constant]       -> F.Symbol       -> F.Sort-      -> QCluster+      -> QCluster        -> Sol.QBind ---------------------------------------------------------------------------------instK ho env lits v t qc = Sol.qb . unique $-  [ Sol.eQual q xs ls+instK ho env v t qc = Sol.qb . unique $ +  [ Sol.eQual q xs        | (sig, qs) <- M.toList qc-      , let (varSig, litSig) =  splitSig sig-      , xs        <- instKSig ho env v t varSig-      , ls        <- instLitSig lits litSig+      , xs        <- instKSig ho env v t sig        , q         <- qs   ] --- split the QCSig into the parts that are for regular variables vs for wildcard-literals that are defined as `a#`, `b#` etc.--- e.g. see tests/horn/pos/wild_lits*.smt2-splitSig :: QCSig -> (QCSig, QCSig)-splitSig = List.partition (\qp -> qpPat qp /= PatLit)--instLitSig :: [F.Constant] -> QCSig -> [[F.Constant]]-instLitSig lits sig = sequence [ filter (matchSort (qpSort qp)) lits | qp <- sig ]--matchSort :: F.Sort -> F.Constant -> Bool-matchSort F.FInt  (F.I _)    = True-matchSort F.FReal (F.R _)    = True-matchSort s       (F.L _ s') = s == s'-matchSort _       _          = False- unique :: [Sol.EQual] -> [Sol.EQual] unique qs = M.elems $ M.fromList [ (Sol.eqPred q, q) | q <- qs ] @@ -148,30 +124,48 @@          -> F.SEnv F.Sort          -> F.Symbol          -> F.Sort-         -> QCSig+         -> QCSig           -> [[F.Symbol]]-instKSig _  _   _ _ [] = error "Empty qsig in Solution.instKSig"-instKSig ho env v sort' (qp:qps) = do-  (su0, i0, qs0) <- candidatesP symToSrch [(0, sort', [v])] qp-  ixs       <- matchP symToSrch tyss [(i0, qs0)] (applyQPP su0 <$> qps)-  ys        <- instSymbol tyss (tail $ reverse ixs)+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        = "instKSig " ++ F.showpp qsig+    qp : qps   = qsig     tyss       = zipWith (\i (t, ys) -> (i, t, ys)) [1..] (instCands ho env)-    symToSrch  = (`F.lookupSEnvWithDistance` env)+    senv       = (`F.lookupSEnvWithDistance` env)  instSymbol :: [(SortIdx, a, [F.Symbol])] -> [(SortIdx, QualPattern)] -> [[F.Symbol]]-instSymbol tyss = go+instSymbol tyss = go    where     m = M.fromList [(i, ys) | (i,_,ys) <- tyss]-    go [] =+    go [] =        return []-    go ((i,qp):is) = do+    go ((i,qp):is) = do        y   <- M.lookupDefault [] i m       qsu <- maybeToList (matchSym qp y)       ys  <- go [ (i', applyQPSubst qsu  qp') | (i', qp') <- is]       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@@ -182,18 +176,18 @@  type SortIdx = Int -matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] ->+matchP :: So.Env -> [(SortIdx, F.Sort, a)] -> [(SortIdx, QualPattern)] -> [F.QualParam] ->            [[(SortIdx, QualPattern)]] matchP env tyss = go-  where+  where      go' !i !p !is !qps  = go ((i, p):is) qps     go is (qp : qps) = do (su, i, pat) <- candidatesP env tyss qp                           go' i pat is (applyQPP su <$> qps)     go is []         = return is  applyQPP :: So.TVSubst -> F.QualParam -> F.QualParam-applyQPP su qp = qp-  { qpSort = So.apply     su  (qpSort qp)+applyQPP su qp = qp +  { qpSort = So.apply     su  (qpSort qp)    }  -- match :: So.Env -> [(F.Sort, [F.Symbol])] -> [F.Symbol] -> [F.QualParam] -> [[F.Symbol]]@@ -204,17 +198,17 @@ --   = return xs  -- applyQP :: So.TVSubst -> QPSubst -> F.QualParam -> F.QualParam--- applyQP su qsu qp = qp---   { qpSort = So.apply     su  (qpSort qp)---   , qpPat  = applyQPSubst qsu (qpPat qp)+-- applyQP su qsu qp = qp +--   { qpSort = So.apply     su  (qpSort qp) +--   , qpPat  = applyQPSubst qsu (qpPat qp)  --   }  ---------------------------------------------------------------------------------candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam ->+candidatesP :: So.Env -> [(SortIdx, F.Sort, a)] -> F.QualParam ->                 [(So.TVSubst, SortIdx, QualPattern)] -------------------------------------------------------------------------------- candidatesP env tyss x =-    [(su, idx, qPat)+    [(su, idx, qPat)          | (idx, t,_)  <- tyss         , su          <- maybeToList (So.unifyFast mono env xt t)     ]@@ -222,52 +216,52 @@     xt   = F.qpSort x     qPat = F.qpPat  x     mono = So.isMono xt+     + -- ----------------------------------------------------------------------------------- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam+-- candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.QualParam  --            -> [(So.TVSubst, QPSubst, F.Symbol)] -- -------------------------------------------------------------------------------- -- candidates env tyss x = -- traceShow _msg --     [(su, qsu, y) | (t, ys)  <- tyss --                   , su       <- maybeToList (So.unifyFast mono env xt t) --                   , y        <- ys---                   , qsu      <- maybeToList (matchSym x y)+--                   , qsu      <- maybeToList (matchSym x y)                                      --     ] --   where --     xt   = F.qpSort x --     mono = So.isMono xt --     _msg = "candidates tyss :=" ++ F.showpp tyss ++ "tx := " ++ F.showpp xt -matchSym :: F.QualPattern -> F.Symbol -> Maybe QPSubst+matchSym :: F.QualPattern -> F.Symbol -> Maybe QPSubst  matchSym qp y' = case qp of-  F.PatPrefix s i -> JustSub i <$> F.stripPrefix s y-  F.PatSuffix i s -> JustSub i <$> F.stripSuffix s y-  F.PatNone       -> Just NoSub-  F.PatExact s    -> if s == y then Just NoSub else Nothing-  F.PatLit        -> Nothing-  where-    y             =  F.unKArgSymbol y'+  F.PatPrefix s i -> JustSub i <$> F.stripPrefix s y +  F.PatSuffix i s -> JustSub i <$> F.stripSuffix s y +  F.PatNone       -> Just NoSub +  F.PatExact s    -> if s == y then Just NoSub else Nothing +  where +    y             =  F.tidySymbol y' -data QPSubst = NoSub | JustSub Int F.Symbol+data QPSubst = NoSub | JustSub Int F.Symbol   -applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern-applyQPSubst (JustSub i x) (F.PatPrefix s j)-  | i == j = F.PatExact (F.mappendSym s x)-applyQPSubst (JustSub i x) (F.PatSuffix j s)-  | i == j = F.PatExact (F.mappendSym x s)-applyQPSubst _ p-  = p+applyQPSubst :: QPSubst -> F.QualPattern -> F.QualPattern +applyQPSubst (JustSub i x) (F.PatPrefix s j) +  | i == j = F.PatExact (F.mappendSym s x) +applyQPSubst (JustSub i x) (F.PatSuffix j s) +  | i == j = F.PatExact (F.mappendSym x s) +applyQPSubst _ p +  = p   ---------------------------------------------------------------------------------okInst :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> Sol.EQual -> ElabM Bool+okInst :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> Sol.EQual -> Bool ---------------------------------------------------------------------------------okInst env v t eq =-  do tc <- So.checkSorted (F.srcSpan eq) env sr-     pure $ isNothing tc+okInst env v t eq = isNothing tc   where     sr            = F.RR t (F.Reft (v, p))     p             = Sol.eqPred eq-    -- _msg          = printf "okInst: t = %s, eq = %s" (F.showpp t) (F.showpp eq)+    tc            = So.checkSorted (F.srcSpan eq) env sr +    -- _msg          = printf "okInst: t = %s, eq = %s, env = %s" (F.showpp t) (F.showpp eq) (F.showpp env)   --------------------------------------------------------------------------------@@ -276,25 +270,22 @@ {-# SCC lhsPred #-} lhsPred   :: (F.Loc a)-  => Config-  -> F.IBindEnv-  -> F.BindEnv a+  => F.IBindEnv+  -> F.BindEnv   -> Sol.Solution   -> F.SimpC a   -> F.Expr-lhsPred cfg bindingsInSmt be s c =-    let ap = apply cfg g s bs-     in F.notracepp _msg $ fst ap+lhsPred bindingsInSmt be s c = F.notracepp _msg $ fst $ apply g s bs   where     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 -data CombinedEnv a = CEnv+data CombinedEnv = CEnv    { ceCid  :: !Cid-  , ceBEnv :: !(F.BindEnv a)-  , ceIEnv :: !F.IBindEnv+  , 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@@ -302,133 +293,116 @@   , ceBindingsInSmt :: !F.IBindEnv   } +instance F.Loc CombinedEnv where +  srcSpan = ceSpan+ type Cid         = Maybe Integer type ExprInfo    = (F.Expr, KInfo) -apply :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> F.IBindEnv -> ExprInfo-apply cfg g s bs =+apply :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ExprInfo+apply g s bs      = (F.conj (pks:ps), kI)   -- see [NOTE: pAnd-SLOW]+  where     -- Clear the "known" bindings for applyKVars, since it depends on     -- using the fully expanded representation of the predicates to bind their     -- variables with quantifiers.-    let xrs = map (lookupBindEnvExt g) (F.elemsIBindEnv bs)-        (ps,  ks) = envConcKVars xrs-        (pks, kI) = applyKVars cfg g {ceBindingsInSmt = F.emptyIBindEnv} s ks-     in (F.conj (pks:ps), kI)   -- see [NOTE: pAnd-SLOW]+    (pks, kI)     = applyKVars g {ceBindingsInSmt = F.emptyIBindEnv} s ks+    (ps,  ks, _)  = envConcKVars g s bs --- | @applyInSortedReft@ applies the solution to a single sorted reft-applyInSortedReft-  :: Config-  -> CombinedEnv ann-  -> Sol.Sol Sol.QBind-  -> (F.Symbol, F.SortedReft)-  -> (F.Symbol, F.SortedReft)-applyInSortedReft cfg g s xsr@(x, sr) =-    let (ps,  ks) = envConcKVars [xsr]-        (pks, _) = applyKVars cfg g {ceBindingsInSmt = F.emptyIBindEnv} s ks-     in (x, sr { F.sr_reft = F.Reft (x, F.conj (pks : ps)) }) --- | Produces conjuncts of each sorted reft in the IBindEnv, separated--- into concrete conjuncts and kvars.-envConcKVars :: [(F.Symbol, F.SortedReft)] -> ([F.Expr], [F.KVSub])-envConcKVars xrs =-  let (pss, kss) = unzip [ F.sortedReftConcKVars x sr | (x, sr) <- xrs ]-   in (concat pss, concat kss)+envConcKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.IBindEnv -> ([F.Expr], [F.KVSub], [F.KVSub])+envConcKVars g s bs = (concat pss, concat kss, L.nubBy (\x y -> F.ksuKVar x == F.ksuKVar y) $ concat gss)+  where+    (pss, kss, gss) = unzip3 [ F.notracepp ("sortedReftConcKVars" ++ F.showpp sr) $ F.sortedReftConcKVars x sr | (x, sr) <- xrs ]+    xrs             = lookupBindEnvExt g s <$> is+    is              = F.elemsIBindEnv bs -lookupBindEnvExt-  :: CombinedEnv ann -> F.BindId -> (F.Symbol, F.SortedReft)-lookupBindEnvExt g i =-     (,) x $-       if F.memberIBindEnv i (ceBindingsInSmt g)-       then sr { F.sr_reft = F.Reft (x, F.EVar (F.bindSymbol (fromIntegral i)))}-       else sr-   where-      (x, sr, _)              = F.lookupBindEnv i (ceBEnv g)+lookupBindEnvExt :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> (F.Symbol, F.SortedReft)+lookupBindEnvExt g s i+  | Just p <- ebSol g {ceBindingsInSmt = F.emptyIBindEnv} s i = (x, sr { F.sr_reft = F.Reft (x, p) })+  | F.memberIBindEnv i (ceBindingsInSmt g) =+      (x, sr { F.sr_reft = F.Reft (x, F.EVar (F.bindSymbol (fromIntegral i)))})+  | otherwise             = (x, sr)+   where +      (x, sr)              = F.lookupBindEnv i (ceBEnv g)  -applyKVars :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> [F.KVSub] -> ExprInfo-applyKVars cfg g s ks =-  let bcs = map (applyKVar cfg g s) ks-      (es, is) = unzip bcs-   in (F.pAndNoDedup es, mconcat is)+ebSol :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.BindId -> Maybe F.Expr+ebSol g s i = case  M.lookup i sebds of+  Just (Sol.EbSol p)    -> Just p+  Just (Sol.EbDef cs _) -> Just $ F.PAnd (cSol <$> cs)+  _                     -> Nothing+  where+    sebds = Sol.sEbd s -applyKVar :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> F.KVSub -> ExprInfo-applyKVar cfg  g s ksu = case Sol.lookup s (F.ksuKVar ksu) of-  Left cs   -> hypPred cfg g s ksu cs-  Right eqs -> let qbp = qbPreds-                           (F.substFromKSubst $ F.ksuSubst ksu)-                           (F.ksuTySub ksu)-                           eqs-                   preds = fst <$> qbp-                in (F.pAndNoDedup preds, mempty) -- TODO: don't initialize kvars that have a hyp solution+    ebReft s (i,c) = exElim (Sol.sxEnv s) (senv c) i (ebindReft g s c)+    cSol c = if sid c == ceCid g +                then F.PFalse+                else ebReft s' (i, c) -qbPreds :: F.Subst -> F.TyVarSubst -> Sol.QBind -> [(F.Pred, Sol.EQual)]-qbPreds su tvsu (Sol.QB eqs) =-  [ (F.subst su $ V.applyCoSub tvsu $ Sol.eqPred eq, eq) | eq <- eqs ]+    s' = s { Sol.sEbd = M.insert i Sol.EbIncr sebds } -mkNonCutsExpr :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> F.KVar -> Sol.Hyp -> F.Expr-mkNonCutsExpr cfg ce s k cs = F.pOr (bareCubePred cfg ce s k <$> cs)+ebindReft :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.SimpC () -> F.Pred+ebindReft g s c = F.pAnd [ fst $ apply g' s bs, F.crhs c ]+  where+    g'          = g { ceCid = sid c, ceIEnv = bs } +    bs          = F.senv c -nonCutsResult :: Config -> F.BindEnv ann -> Sol.Sol Sol.QBind -> FixDelayedSolution-nonCutsResult cfg be s = M.mapWithKey (\k -> Delayed . mkNonCutsExpr cfg g s k) $ Sol.sHyp s+exElim :: F.SEnv (F.BindId, F.Sort) -> F.IBindEnv -> F.BindId -> F.Pred -> F.Pred+exElim env ienv xi p = F.notracepp msg (F.pExist yts p)   where-    g = CEnv Nothing be F.emptyIBindEnv F.dummySpan F.emptyIBindEnv+    msg         = "exElim" -- printf "exElim: ix = %d, p = %s" xi (F.showpp p)+    yts         = [ (y, yt) | y        <- F.syms p+                            , (yi, yt) <- maybeToList (F.lookupSEnv y env)+                            , xi < yi+                            , yi `F.memberIBindEnv` ienv                  ] +applyKVars :: CombinedEnv -> Sol.Sol a Sol.QBind -> [F.KVSub] -> ExprInfo+applyKVars g s = mrExprInfos (applyKVar g s) F.pAndNoDedup mconcat +applyKVar :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> ExprInfo+applyKVar g s ksu = case Sol.lookup s (F.ksuKVar ksu) of+  Left cs   -> hypPred g s ksu cs+  Right eqs -> (F.pAndNoDedup $ fst <$> Sol.qbPreds msg s (F.ksuSubst ksu) eqs, mempty) -- TODO: don't initialize kvars that have a hyp solution+  where+    msg     = "applyKVar: " ++ show (ceCid g)++nonCutsResult :: F.BindEnv -> Sol.Sol a Sol.QBind -> M.HashMap F.KVar F.Expr+nonCutsResult 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. ----- 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.------ Where the cube rhs is @k[params:=xts]@, we keep the parameters free in the--- final predicate. e.g. @params == xts && exists yts . ...@--- That is, we only quantify out the `yts` as we want to make--- explicit what equalities those parameters have in each cube.------ Issue https://github.com/ucsd-progsys/liquid-fixpoint/issues/808 discusses--- an example where the equalities are essential to keep.--bareCubePred :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> F.KVar -> Sol.Cube -> F.Expr-bareCubePred cfg g s k c =-    let psu = F.pAnd [ F.EEq (F.expr x) e | (x, e) <- M.toList m ]-        (p, _kI) = apply cfg g' s bs-     in F.pExist yts (p F.&.& psu)-  where-    bs     = Sol.cuBinds c-    F.Su m = dropUnsortedExprs cfg g' (Sol.cuSubst c)-    g'     = addCEnv  g bs-    bs'    = F.diffIBindEnv bs (Misc.safeLookup "sScp" k (Sol.sScp s))-    yts    = symSorts g bs'---- | At the moment, the liquid-fixpoint implementation allows for unsorted--- expressions in substitutions. See the discussion in--- https://github.com/ucsd-progsys/liquid-fixpoint/issues/800--- The `explicitKvars` flag is meant for Horn-style constraints, which must--- have well-formed (expressions) as arguments, and so we *disable* the--- filtering of unsorted expressions when that flag is set.-dropUnsortedExprs :: Config -> CombinedEnv ann -> F.Subst -> F.Subst-dropUnsortedExprs cfg g su@(F.Su m)-  | explicitKvars cfg = su-  | otherwise         = F.Su $-    M.filter-      (\e -> isJust $ do-         t <- So.checkSortExpr sp env e-         guard (not (isClass t))-      )-      m-  where-    sp  = ceSpan g-    env = combinedSEnv g+-- 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 :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> F.KVSub -> Sol.Hyp -> ExprInfo-hypPred cfg g s ksu hyp =-  let cs = map (cubePred cfg g s ksu) hyp-   in F.pOr *** mconcatPlus $ unzip cs+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  {- | `cubePred g s k su c` returns the predicate for @@ -438,66 +412,146 @@          c := [b1,...,bn] |- (k . su') -      in the binder environment `g`. The binders in `sScp s k` are not included-      in the final predicate. They are considered redundant conjuncts as per-      section 2.4 of "Local Refinement Typing", ICFP 2017.+      in the binder environment `g`.++        bs' := the subset of "extra" binders in [b1...bn] that are *not* in `g`+        p'  := the predicate corresponding to the "extra" binders+  -}-cubePred :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> F.KVSub -> Sol.Cube -> ExprInfo-cubePred cfg g s ksu c    =-    let (p, kI) = cubePredExc cfg g s c bs'-        -- Free variables in p should not colide with those generated by-        -- the rapier substitution. If that were the case, perhaps we would-        -- need to include @combinedSEnv g@ in the scope set.-        p' = F.rapierSubstExpr (F.substSymbolsSet su) su $-             V.applyCoSub (F.ksuTySub ksu) p-     in (p', kI)++elabExist :: F.SrcSpan -> Sol.Sol a Sol.QBind -> [(F.Symbol, F.Sort)] -> F.Expr -> F.Expr+elabExist sp s xts p = F.pExist xts' p   where-    bs' = F.diffIBindEnv bs (Misc.safeLookup "sScp" k (Sol.sScp s))-    bs  = Sol.cuBinds c-    k   = F.ksuKVar ksu-    su = dropUnsortedExprs cfg g (F.substFromKSubst $ F.ksuSubst  ksu)+    xts'        = [ (x, elab t) | (x, t) <- xts]+    elab        = So.elaborate (F.atLoc sp "elabExist") env+    env         = Sol.sEnv s +cubePred :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> ExprInfo+cubePred g s ksu c    = (F.notracepp "cubePred" $ elabExist sp s xts (psu &.& p), kI)+  where+    sp                = F.srcSpan g+    ((xts,psu,p), kI) = cubePredExc g s ksu c bs'+    bs'               = delCEnv s k bs+    bs                = Sol.cuBinds c+    k                 = F.ksuKVar ksu++type Binders = [(F.Symbol, F.Sort)]+ -- | @cubePredExc@ computes the predicate for the subset of binders bs'.------ Schematically, the result is------ > Exists (bindsOf bs'). (pAnd (predicatesOf bs'))[Sol.cuSubst c]------ but we also preserve the information about which variables are being--- substituted:------ > Exists (bindsOf bs'). pAnd (predicatesOf bs') && x1=e1 && ... && xn=en------ where @Sol.cuSubst c = [x1:=e1;...;xn:=en]@.----cubePredExc :: Config -> CombinedEnv ann -> Sol.Sol Sol.QBind -> Sol.Cube -> F.IBindEnv-            -> (F.Pred, KInfo)-cubePredExc cfg g s c bs' =-    let psu' = F.pAnd [ F.EEq (F.expr x) e | (x, e) <- M.toList m ]-        (p', kI) = apply cfg g' s bs'-        cubeE = F.pExist yts' (F.pAndNoDedup [p', psu'])-     in (cubeE, extendKInfo kI (Sol.cuTag c))+--   The output is a tuple, `(xts, psu, p, kI)` such that the actual predicate+--   we want is `Exists xts. (psu /\ p)`.++cubePredExc :: CombinedEnv -> Sol.Sol a Sol.QBind -> F.KVSub -> Sol.Cube -> F.IBindEnv+            -> ((Binders, F.Pred, F.Pred), KInfo)++cubePredExc g s ksu c bs' = (cubeP, extendKInfo kI (Sol.cuTag c))   where-    yts' = symSorts g bs'-    g' = addCEnv  g bs-    F.Su m = dropUnsortedExprs cfg g' (Sol.cuSubst c)-    bs = Sol.cuBinds c+    cubeP           = (xts, psu, elabExist sp s yts' (F.pAndNoDedup [p', psu']) )+    sp              = F.srcSpan g+    yts'            = symSorts g bs'+    g'              = addCEnv  g bs+    (p', kI)        = apply g' s bs'+    (_  , psu')     = substElim (Sol.sEnv s) sEnv g' k su'+    (xts, psu)      = substElim (Sol.sEnv s) sEnv g  k su+    su'             = Sol.cuSubst c+    bs              = Sol.cuBinds c+    k               = F.ksuKVar   ksu+    su              = F.ksuSubst  ksu+    sEnv            = F.insertSEnv (F.ksuVV ksu) (F.ksuSort ksu) (F.seSort $ Sol.sEnv s) +-- TODO: SUPER SLOW! Decorate all substitutions with Sorts in a SINGLE pass.++{- | @substElim@ returns the binders that must be existentially quantified,+     and the equality predicate relating the kvar-"parameters" and their+     actual values. i.e. given++        K[x1 := e1]...[xn := en]++     where e1 ... en have types t1 ... tn+     we want to quantify out++       x1:t1 ... xn:tn++     and generate the equality predicate && [x1 ~~ e1, ... , xn ~~ en]+     we use ~~ because the param and value may have different sorts, see:++        tests/pos/kvar-param-poly-00.hs++     Finally, we filter out binders if they are++     1. "free" in e1...en i.e. in the outer environment.+        (Hmm, that shouldn't happen...?)++     2. are binders corresponding to sorts (e.g. `a : num`, currently used+        to hack typeclasses current.)+ -}+substElim :: F.SymEnv -> F.SEnv F.Sort -> CombinedEnv -> F.KVar -> F.Subst -> ([(F.Symbol, F.Sort)], F.Pred)+substElim syEnv sEnv g _ (F.Su m) = (xts, p)+  where+    p      = F.pAnd [ mkSubst sp syEnv x (substSort sEnv frees x t) e t | (x, e, t) <- xets  ]+    xts    = [ (x, t)    | (x, _, t) <- xets, not (S.member x frees) ]+    xets   = [ (x, e, t) | (x, e)    <- xes, t <- sortOf e, not (isClass t)]+    xes    = M.toList m+    env    = combinedSEnv g+    frees  = S.fromList (concatMap (F.syms . snd) xes)+    sortOf = maybeToList . So.checkSortExpr sp env+    sp     = F.srcSpan g++substSort :: F.SEnv F.Sort -> S.HashSet F.Symbol -> F.Symbol -> F.Sort -> F.Sort+substSort sEnv _frees x _t = fromMaybe (err x) $ F.lookupSEnv x sEnv+  where+    err x            = error $ "Solution.mkSubst: unknown binder " ++ F.showpp x+++-- LH #1091+mkSubst :: F.SrcSpan -> F.SymEnv -> F.Symbol -> F.Sort -> F.Expr -> F.Sort -> F.Expr+mkSubst sp env x tx ey ty+  | tx == ty    = F.EEq ex ey+  | otherwise   = {- F.tracepp _msg -} (F.EEq ex' ey')+  where+    _msg         = "mkSubst-DIFF:" ++ F.showpp (tx, ty) ++ F.showpp (ex', ey')+    ex          = F.expr x+    ex'         = elabToInt sp env ex tx+    ey'         = elabToInt sp env ey ty++elabToInt :: F.SrcSpan -> F.SymEnv -> F.Expr -> F.Sort -> F.Expr+elabToInt sp env e s = So.elaborate (F.atLoc sp "elabToInt") env (So.toInt env e s)+ isClass :: F.Sort -> Bool isClass F.FNum  = True isClass F.FFrac = True isClass _       = False -combinedSEnv :: CombinedEnv a -> F.SEnv F.Sort+--badExpr :: CombinedEnv -> F.KVar -> F.Expr -> a+--badExpr g@(i,_,_) k e+  -- = errorstar $ "substSorts has a badExpr: "+              -- ++ show e+              -- ++ " in cid = "+              -- ++ show i+              -- ++ " for kvar " ++ show k+              -- ++ " in env \n"+              -- ++ show (combinedSEnv g)++-- substPred :: F.Subst -> F.Pred+-- substPred (F.Su m) = F.pAnd [ F.PAtom F.Eq (F.eVar x) e | (x, e) <- M.toList m]++combinedSEnv :: CombinedEnv -> F.SEnv F.Sort combinedSEnv g = F.sr_sort <$> F.fromListSEnv (F.envCs be bs)-  where-    be         = ceBEnv g-    bs         = ceIEnv g+  where +    be         = ceBEnv g +    bs         = ceIEnv g  -addCEnv :: CombinedEnv a -> F.IBindEnv -> CombinedEnv a+addCEnv :: CombinedEnv -> F.IBindEnv -> CombinedEnv addCEnv g bs' = g { ceIEnv = F.unionIBindEnv (ceIEnv g) bs' }+-- addCEnv (x, be, bs) bs' = (x, be, F.unionIBindEnv bs bs') -symSorts :: CombinedEnv a -> F.IBindEnv -> [(F.Symbol, F.Sort)]++delCEnv :: Sol.Sol a Sol.QBind -> F.KVar -> F.IBindEnv -> F.IBindEnv+delCEnv s k bs = F.diffIBindEnv bs _kbs+  where+    _kbs       = Misc.safeLookup "delCEnv" k (Sol.sScp s)++symSorts :: CombinedEnv -> F.IBindEnv -> [(F.Symbol, F.Sort)] symSorts g bs = second F.sr_sort <$> F.envCs (ceBEnv g) bs  _noKvars :: F.Expr -> Bool@@ -522,11 +576,11 @@   mempty  = KI [] 0 1   mappend = (<>) -mplusKInfo :: KInfo -> KInfo -> KInfo-mplusKInfo ki ki' = (mappend ki ki') { kiCubes = kiCubes ki + kiCubes ki'}+mplus :: KInfo -> KInfo -> KInfo+mplus ki ki' = (mappend ki ki') { kiCubes = kiCubes ki + kiCubes ki'}  mconcatPlus :: [KInfo] -> KInfo-mconcatPlus = foldr mplusKInfo mempty+mconcatPlus = foldr mplus mempty  appendTags :: [Tag] -> [Tag] -> [Tag] appendTags ts ts' = Misc.sortNub (ts ++ ts')@@ -535,171 +589,50 @@ extendKInfo ki t = ki { kiTags  = appendTags [t] (kiTags  ki)                       , kiDepth = 1  +            kiDepth ki } --- | Simplifies existential expressions with unused or inconsequential bindings.------ Simplification is helpful for human readability of solutions. It makes easier--- reporting errors. Sometimes it can be useful for debugging if run on queries--- sent to the SMT solver. We don't do that by default because some benchmarks--- show a slowdown in some cases.------ For instance, in the following example, "x" is not used at all.------ > simplifyKVar "exists x y. y == z && y == C"--- >   ==--- > "exists y. y == z && y == C"------ And in the following example, @x@ is used but in a way that doesn't--- contribute any useful knowledge.------ > simplifyKVar "exists x y. x == C && y == z && y == C"--- >   ==--- > "exists y. y == z && y == C"------ Therefore we eliminate variables that appear in equalities via substitutions.------ > simplifyKVar "exists x y. x == C && P && Q y"--- >   ==--- > "exists y. (P && Q y)[x:=C]"------ The first parameter is the set of symbols that can appear free in the input--- expression. At the moment, this only needs to include the free variables that--- start with the @subst$@ prefix.----simplifyKVar :: S.HashSet F.Symbol -> F.Expr -> F.Expr-simplifyKVar s0 = F.conj . dedupByAlphaEq s0 . floatPExistConjuncts . go s0+-- mrExprInfos :: (a -> ExprInfo) -> ([F.Expr] -> F.Expr) -> ([KInfo] -> KInfo) -> [a] -> ExprInfo+mrExprInfos :: (a -> (b, c)) -> ([b] -> b1) -> ([c] -> c1) -> [a] -> (b1, c1)+mrExprInfos mF erF irF xs = (erF es, irF is)   where-    go s (F.POr es) = disj $ map (F.conj . floatPExistConjuncts . go s) es-    go s (F.PAnd es) = F.conj $ dedupByAlphaEq S.empty $ concatMap (floatPExistConjuncts . go s) es-    go s (F.PExist bs e0) =-      let es = concatMap (floatPExistConjuncts . go (S.union s $ S.fromList $ map fst bs)) (F.conjuncts e0)-       in elimExistentialBinds (F.PExist bs (F.conj es))-    go _ e = e--    dedupByAlphaEq :: S.HashSet F.Symbol -> [F.Expr] -> [F.Expr]-    dedupByAlphaEq s = List.nubBy (\e1 e2 -> alphaEq s e1 e2)--    disj :: [F.Expr] -> F.Expr-    disj [] = F.PFalse-    disj [e] = e-    disj es = F.POr es--    elimExistentialBinds (F.PExist bs0 (F.PExist bs1 p)) =-      let bs0' = filter (\(x,_) -> x `notElem` map fst bs1) bs0-       in elimExistentialBinds (F.PExist (bs0' ++ bs1) p)-    elimExistentialBinds (F.PExist bs e0) =-      let es = F.conjuncts e0-          esv = map (isVarEq (map fst bs)) es-          -- Eliminating multiple variables at once can be difficult if the-          -- equalities define cyclic dependencies, so we only eliminate one-          -- variable at a time.-          esvElim = take 1 [ (x, v) | (Just (x, v), _) <- esv ]-          esvKeep =-            let (xs, ys) = break (isJust . fst) esv-             in map snd (xs ++ drop 1 ys)-          su = F.mkSubst esvElim-          e' = F.rapierSubstExpr (F.substSymbolsSet su) su $ F.conj esvKeep-          bs' = filter ((`S.member` F.exprSymbolsSet e') . fst) bs-          e'' = F.pExist bs' e'-       in-          if null esvElim then e'' else elimExistentialBinds e''-    elimExistentialBinds e = e+    (es, is)              = unzip $ map mF xs -    -- | Float out conjuncts from an existential expression that does not-    -- depend on the existentially bound variables.-    floatPExistConjuncts :: F.Expr -> [F.Expr]-    floatPExistConjuncts e0@(F.PExist bs es0) =-      let es = F.conjuncts es0-          (floatable, nonFloatable) =-           List.partition (isFloatableConjunct (S.fromList (map fst bs))) es-       in-          if null floatable then-            [e0]-          else-            elimExistentialBinds (F.pExist bs (F.conj nonFloatable)) : floatable-      where-        isFloatableConjunct :: S.HashSet F.Symbol -> F.Expr -> Bool-        isFloatableConjunct s e = S.null $ S.intersection (F.exprSymbolsSet e) s-    floatPExistConjuncts e = [e]+--------------------------------------------------------------------------------+-- | `ebindInfo` constructs the information about the "ebind-definitions". +--------------------------------------------------------------------------------+ebindInfo :: F.SInfo a -> [(F.BindId, Sol.EbindSol)]+ebindInfo si = group [((bid, x), cons cid) | (bid, cid, x) <- ebindDefs si]+  where cons cid = const () <$> Misc.safeLookup "ebindInfo" cid cs+        cs = F.cm si+        cmpByFst x y = fst ( fst x ) == fst ( fst y )+        group xs = (\ys -> ( (fst $ fst $ head ys)+                           , Sol.EbDef (snd <$> ys) (snd $ fst $ head ys)))+                    <$> L.groupBy cmpByFst xs --- | Determine if two expressions are alpha-equivalent.------ Takes as first parameter the set of variables that might appear free--- in the expressions to compare.------ Doesn't handle all cases, just enough for simplifying KVars which requires--- alpha-equivalence checking of existentially quantified expressions.-alphaEq :: S.HashSet F.Symbol -> F.Expr -> F.Expr -> Bool-alphaEq s0 = go s0 (F.mkSubst [])-  where-    go :: S.HashSet F.Symbol -> F.Subst -> F.Expr -> F.Expr -> Bool-    go s su (F.PExist bs1 x1) (F.PExist bs2 x2) =-      let su' =-            List.foldl'-              (\su1 (v1, v2) -> F.extendSubst su1 v1 (F.EVar v2))-              su-              (zip (map fst bs1) (map fst bs2))-       in go (S.union s (S.fromList $ map fst bs2)) su' x1 x2-    go s su (F.PAnd es1) (F.PAnd es2) =-      length es1 == length es2 && and (zipWith (go s su) es1 es2)-    go s su (F.POr es1) (F.POr es2) =-      length es1 == length es2 && and (zipWith (go s su) es1 es2)-    go s su e1 e2 =-      F.rapierSubstExpr s su e1 == e2+ebindDefs :: F.SInfo a -> [(F.BindId, F.SubcId, F.Symbol)]+ebindDefs si = [ (bid, cid, x) | (cid, x) <- cDefs+                               , bid      <- maybeToList (M.lookup x ebSyms)]+  where +    ebSyms   = ebindSyms si +    cDefs    = cstrDefs  si  --- | Determine if the expression is an equality that sets the value of--- a variable in the given set.------ @isVarEq fvs e@ yields @(Just (v, e'), e)@ if @v@ is in @fvs@, and @e@ has--- the form @v == e'@.-isVarEq :: [F.Symbol] -> F.Expr -> (Maybe (F.Symbol, F.Expr), F.Expr)-isVarEq fvs ei0 = case ei0 of-  F.PAtom brel e0 e1-    | isEqRel brel ->-      let m :: Maybe (F.Symbol, F.Expr)-          m = do-            (v, ei) <- ((,e1) <$> isVarIn e0 fvs) `mplus`-                       ((,e0) <$> isVarIn e1 fvs)-            () <- guard (not (S.member v (F.exprSymbolsSet ei)))-            return (v, ei)-       in (m, ei0)-  _ ->-    (Nothing, ei0)+ebindSyms :: F.SInfo a -> M.HashMap F.Symbol F.BindId+ebindSyms si = M.fromList [ (xi, bi) | bi        <- ebinds si+                                     , let (xi,_) = F.lookupBindEnv bi be ]    where-    -- | Tells if the binary relation is an equality.-    isEqRel :: F.Brel -> Bool-    isEqRel F.Eq = True-    isEqRel F.Ueq = True-    isEqRel _ = False--    -- | @isVarIn s fvs@ yields @Just s@ if @s@ is a variable and it is in-    -- @fvs@.-    isVarIn :: F.Expr -> [F.Symbol] -> Maybe F.Symbol-    isVarIn (F.EVar s) vs-      | elem s vs = Just s-    isVarIn _ _vs = Nothing+    be       = F.bs si + +cstrDefs :: F.SInfo a -> [(F.SubcId, F.Symbol)]+cstrDefs si = [(cid, x) | (cid, c) <- M.toList (cm si)+                        , x <- maybeToList (cstrDef be c) ]+  where +    be      = F.bs si ------------------------------------------------------------------------------------ | Save Solution to File --------------------------------------------------------------------------------------------------------------------------------------+cstrDef :: F.BindEnv -> F.SimpC a -> Maybe F.Symbol +cstrDef be c +  | Just (F.EVar x) <- e = Just x +  | otherwise            = Nothing +  where +    (v,_)              = F.lookupBindEnv (cbind c) be +    e                  = F.notracepp _msg $ F.isSingletonExpr v rhs +    _msg                = "cstrDef: " ++ show (stag c) ++ " crhs = " ++ F.showpp rhs +    rhs                = V.stripCasts (crhs c) -saveSolution :: Config -> String -> Result a -> IO ()-saveSolution cfg sfx res = when (save cfg) $ do-  let f = Files.tempFileName (srcFile cfg ++ sfx ++ ".fqout")-  putStrLn $ "Saving Solution: " ++ f ++ "\n"-  ensurePath f-  writeFile f $ unlines $-    [ ""-    , "Solution:"-    , scopedRender (resSolution  res)-    ] ++-    [ ""-    , ""-    , "Non-cut kvars:"-    , ""-    , scopedRender (M.map forceDelayed $ resNonCutsSolution res)-    ]-    where-      scopedRender = PJ.render . PJ.vcat . map ncDoc . scoped-      scoped sol = [ (k, scope k, So.unApply e) | (k, e) <- M.toList sol]-      scope k = M.lookupDefault [] k $ resSorts res-      ncDoc (k, xts, e) = PJ.hsep [ F.pprint k PJ.<> F.pprint xts, PJ.text ":=", F.pprint e ]
src/Language/Fixpoint/Solver/Solve.hs view
@@ -1,30 +1,24 @@ {-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TupleSections     #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections     #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-}- -------------------------------------------------------------------------------- -- | Solve a system of horn-clause constraints --------------------------------- -------------------------------------------------------------------------------- -module Language.Fixpoint.Solver.Solve (solve) where+module Language.Fixpoint.Solver.Solve (solve, solverInfo) where -import           Control.Monad (forM, when, filterM)-import           Control.Monad.Reader+import           Control.Monad (when, filterM)+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 import qualified Language.Fixpoint.Types.Solutions as Sol import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Config hiding (stats)-import           Language.Fixpoint.SortCheck          (ElabParam(..), elaborate)-import           Language.Fixpoint.Solver.Sanitize (symbolEnv) import qualified Language.Fixpoint.Solver.Solution  as S-import qualified Language.Fixpoint.Smt.Types as T import qualified Language.Fixpoint.Solver.Worklist  as W import qualified Language.Fixpoint.Solver.Eliminate as E import           Language.Fixpoint.Solver.Monad@@ -32,75 +26,40 @@ import           Language.Fixpoint.Graph import           Text.PrettyPrint.HughesPJ import           Text.Printf-import           Language.Fixpoint.Verbosity+import           System.Console.CmdArgs.Verbosity -- (whenNormal, whenLoud) import           Control.DeepSeq import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S--- import qualified Data.Maybe          as Mb+-- import qualified Data.Maybe          as Mb  import qualified Data.List           as L import Language.Fixpoint.Types (resStatus, FixResult(Unsafe))-import Language.Fixpoint.Smt.Interface (smtComment)-import Language.Fixpoint.Solver.Interpreter (instInterpreter)-import qualified Language.Fixpoint.Solver.PLE as PLE      (instantiate)-import Data.Maybe (maybeToList)--mytrace :: String -> a -> a-mytrace-  -- s x = trace s x-  _ x = x-{--solve_ :: (NFData a, F.Fixpoint a, F.Loc a)-       => Config-       -> F.SInfo a-       -> Sol.Solution-       -> W.Worklist a-       -> SolveM a (F.Result (Integer, a), Stats)-       -}---------------------------------------------------------------------------------+import qualified Language.Fixpoint.Types.Config as C+import Language.Fixpoint.Solver.Instantiate (instantiate)  ---------------------------------------------------------------------------------solve-  :: forall a. (NFData a, F.Fixpoint a, Show a, F.Loc a)-  => Config -> ElabParam -> F.SInfo a -> IO (F.Result (Integer, a))+solve :: (NFData a, F.Fixpoint a, Show a, F.Loc a) => Config -> F.SInfo a -> IO (F.Result (Integer, a)) -------------------------------------------------------------------------------- -solve cfg elabParam fi = do+solve cfg fi = do     whenLoud $ donePhase Misc.Loud "Worklist Initialize"     vb <- getVerbosity-    (res, stat) <- (if Quiet == vb then id else withProgressFI sI) $ runSolverM cfg sI elabParam act+    (res, stat) <- (if (Quiet == vb || gradual cfg) then id else withProgressFI sI) $ runSolverM cfg sI act     when (solverStats cfg) $ printStats fi wkl stat     -- print (numIter stat)     return res   where-    act :: SolveM a (F.Result (Integer, a), Stats)-    act = do-      ctx <- getContext-      let sEnv = symbolEnv cfg fi-          s1 = s0{Sol.sMap = M.map (elabQBind ctx "solve" sEnv) (Sol.sMap s0)}-      solve_ cfg fi s1 wkl-    -- solverInfo computes the set of cut and non-cut kvars, then initializes-    -- the solutions of the non-cut KVars (in the sHyp field)-    ---    -- S.init provides an initial solution for the cut KVars-    sI  = solverInfo cfg fi-    wkl = W.init sI-    s0  = (siSol sI) { Sol.sMap = S.init cfg fi ks }-    ks  = siVars sI-    elabQBind ctx msg env (Sol.QB xs) = Sol.QB (map elabEQual xs)-      where-        elabEQual eq =-          eq { Sol.eqPred =-                elaborate-                 (ElabParam (T.ctxElabF ctx) (F.atLoc F.dummySpan msg) env)-                 (Sol.eqPred eq)-             }+    act  = solve_ cfg fi s0 ks  wkl+    sI   = solverInfo cfg fi+    wkl  = W.init sI+    s0   = siSol  sI+    ks   = siVars sI   -------------------------------------------------------------------------------- -- | Progress Bar ---------------------------------------------------------------------------------withProgressFI :: SolverInfo a -> IO b -> IO b-withProgressFI = withProgress . (+ 1) . fromIntegral . cNumScc . siDeps+withProgressFI :: SolverInfo a b -> IO b -> IO b+withProgressFI = withProgress . (+ 1) . fromIntegral . cNumScc . siDeps   --------------------------------------------------------------------------------  printStats :: F.SInfo a ->  W.Worklist a -> Stats -> IO ()@@ -109,173 +68,133 @@     ppTs          = putStrLn . showpp . mconcat  ---------------------------------------------------------------------------------solverInfo :: Config -> F.SInfo a -> SolverInfo a+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+    cD          = elimDeps fI (kvEdges fI) mempty mempty  siKvars :: F.SInfo a -> S.HashSet F.KVar siKvars = S.fromList . M.keys . F.ws -doInterpret :: (F.Loc a) =>  Config -> F.SInfo a -> [F.SubcId] -> SolveM a (F.BindEnv a)-doInterpret cfg fi subcIds = liftIO $ instInterpreter cfg fi (Just subcIds) +{-# 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        -> Sol.Solution+       -> S.HashSet F.KVar        -> W.Worklist a-       -> SolveM a (F.Result (Integer, a), Stats)+       -> SolveM (F.Result (Integer, a), Stats) ---------------------------------------------------------------------------------solve_ cfg fi s2 wkl = do-  liftSMT $ smtComment "solve: start"-  (s3, res0) <- sendConcreteBindingsToSMT F.emptyIBindEnv (F.bs fi) $ \bindingsInSmt -> do+solve_ cfg fi s0 ks wkl = do+  let s1   = {-# SCC "sol-init" #-} S.init cfg fi ks+  let s2   = mappend s0 s1+  (s3, res0) <- sendConcreteBindingsToSMT F.emptyIBindEnv $ \bindingsInSmt -> do     -- let s3   = solveEbinds fi s2-    s3       <- {- SCC "sol-refine" -} refine bindingsInSmt (F.bs fi) s2 wkl-    res0     <- {- SCC "sol-result" -} result bindingsInSmt cfg fi (W.unsatCandidates wkl) s3+    s3       <- {- SCC "sol-refine" #-} refine bindingsInSmt s2 wkl+    res0     <- {- SCC "sol-result" #-} result bindingsInSmt cfg wkl s3     return (s3, res0)--  (fi1, res1) <- case resStatus res0 of  {- first run the interpreter -}-    Unsafe _ bads | rewriteAxioms cfg && interpreter cfg -> do-      liftSMT $ smtComment "solve: interpreter"-      bs <- doInterpret cfg fi (map fst $ mytrace ("before the Interpreter " ++ show (length bads) ++ " constraints remain") bads)-      let fi1 = fi { F.bs = bs }-          badCs = lookupCMap (F.cm fi) <$> map fst bads-      liftSMT $ smtComment "solve: pos-interpreter check"-      fmap (fi1,) $ sendConcreteBindingsToSMT F.emptyIBindEnv bs $ \bindingsInSmt ->-        result bindingsInSmt cfg fi1 badCs s3-    _ -> return  (fi, mytrace "all checked before interpreter" res0)--  res2  <- case resStatus res1 of  {- then run normal PLE on remaining unsolved constraints -}-    Unsafe _ bads2 | rewriteAxioms cfg -> do-      when (save cfg) $-        liftIO $ S.saveSolution cfg ".pre-ple" res1-      liftSMT $ smtComment "solve: ple"-      bs <- liftSMT $ PLE.instantiate cfg fi1 (Just s3) (Just $ map fst bads2)-      -- Check the constraints one last time after PLE-      let fi2 = fi { F.bs = bs }-          badsCs2 = lookupCMap (F.cm fi) <$> map fst bads2-      liftSMT $ smtComment "solve: pos-ple check"-      sendConcreteBindingsToSMT F.emptyIBindEnv bs $ \bindingsInSmt ->-        result bindingsInSmt cfg fi2 badsCs2 s3-    _ -> return $ mytrace "all checked with interpreter" res1--  liftSMT $ smtComment "solve: finished"+  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 res3 = {- SCC "sol-tidy" -} tidyResult cfg res2-  return $!! (res3, st)-+  let res' = {- SCC "sol-tidy"   #-} tidyResult res+  return $!! (res', st)  -------------------------------------------------------------------------------- -- | tidyResult ensures we replace the temporary kVarArg names introduced to --   ensure uniqueness with the original names in the given WF constraints. ---------------------------------------------------------------------------------tidyResult :: Config -> F.Result a -> F.Result a-tidyResult _ r = r+tidyResult :: F.Result a -> F.Result a+tidyResult r = r   { F.resSolution = tidySolution (F.resSolution r)-  , F.resNonCutsSolution = M.map (fmap tidyPred) (F.resNonCutsSolution r)-  , F.resSorts = fmap tidyBind <$>  F.resSorts r+  , F.resNonCutsSolution = tidySolution (F.resNonCutsSolution r)   }  tidySolution :: F.FixSolution -> F.FixSolution tidySolution = fmap tidyPred -tidyBind :: (F.Symbol, F.Sort) -> (F.Symbol, F.Sort)-tidyBind (x, t) = (F.tidySymbol x, t)- tidyPred :: F.Expr -> F.Expr-tidyPred =  go-  where-    ts = F.tidySymbol-    tb = tidyBind-    go (F.EApp s e)      = F.EApp (go s) (go e)-    go (F.ELam (x,t) e)  = F.ELam (ts x, t) (go e)-    go (F.ECoerc a t e)  = F.ECoerc a t (go e)-    go (F.ENeg e)        = F.ENeg (go e)-    go (F.EBin op e1 e2) = F.EBin op (go e1) (go e2)-    go (F.ELet x e1 e2)  = F.ELet (ts x) (go e1) (go e2)-    go (F.EIte p e1 e2)  = F.EIte (go p) (go e1) (go e2)-    go (F.ECst e so)     = F.ECst (go e) so-    go (F.EVar x)        = F.EVar (ts x)-    go (F.PAnd ps)       = F.PAnd $ map go ps-    go (F.POr  ps)       = F.POr  $ map go ps-    go (F.PNot p)        = F.PNot $ go p-    go (F.PImp p1 p2)    = F.PImp (go p1) (go p2)-    go (F.PIff p1 p2)    = F.PIff (go p1) (go p2)-    go (F.PAtom r e1 e2) = F.PAtom r (go e1) (go e2)-    go (F.PExist xts e)  = F.PExist (tb <$> xts) (go e)-    go (F.PAll xts e)    = F.PAll   (tb <$> xts) (go e)-    go  p                = p+tidyPred = F.substf (F.eVar . F.tidySymbol)  -------------------------------------------------------------------------------- {-# SCC refine #-}--- | Implementation of the inference algorithm from:------ "Liquid Types", PLDI 2008, https://ranjitjhala.github.io/static/liquid_types.pdf--- refine-  :: forall a. F.Loc a+  :: (F.Loc a)   => F.IBindEnv-  -> F.BindEnv a   -> Sol.Solution   -> W.Worklist a-  -> SolveM a Sol.Solution+  -> SolveM Sol.Solution ---------------------------------------------------------------------------------refine bindingsInSmt be0 s0 w0 = go be0 s0 w0+refine bindingsInSmt s w+  | Just (c, w', newScc, rnk) <- W.pop w = do+     i       <- tickIter newScc+     (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 bindingsInSmt s' w''+  | otherwise = return s   where-    go :: F.BindEnv a -> Sol.Solution -> W.Worklist a -> SolveM a Sol.Solution-    go be s w-      | Just (c, w', newScc, rnk) <- W.pop w = do-         i       <- tickIter newScc-         (b, s') <- refineC bindingsInSmt be i s c-         lift $ writeLoud $ refineMsg i c b rnk (showpp s')-         let w'' = if b then W.push c w' else w'-         go be s' w''-      | otherwise = return s-      where-        -- DEBUG-        refineMsg i c b rnk s = printf "\niter=%d id=%d change=%s rank=%d s=%s\n"-                                 i (F.subcId c) (show b) rnk s+    -- 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 ----------------------------------------------- --------------------------------------------------------------------------- {-# SCC refineC #-} refineC-  :: forall a. (F.Loc a)+  :: (F.Loc a)   => F.IBindEnv-  -> F.BindEnv a   -> Int   -> Sol.Solution   -> F.SimpC a-  -> SolveM a (Bool, Sol.Solution)+  -> SolveM (Bool, Sol.Solution) ----------------------------------------------------------------------------refineC bindingsInSmt be _i s c =-  do let krhs = rhsCands s-     cfg <- T.config <$> getContext-     if all (null . snd) krhs-        then return (False, s)-        else do-          let lhs = S.lhsPred cfg bindingsInSmt be s c-          kqs <- forM krhs $ \(k, rhs) ->-            (,) k . Sol.QB <$> filterValid (cstrSpan c) lhs rhs-          return $ S.update s kqs+refineC bindingsInSmt _i s c+  | null rhs  = return (False, s)+  | otherwise = do be     <- getBinds+                   let lhs = S.lhsPred bindingsInSmt be s c+                   kqs    <- filterValid (cstrSpan c) lhs rhs+                   return  $ S.update s ks kqs   where-    rhsCands :: Sol.Solution -> [(F.KVar, Sol.Cand Sol.EQual)]-    rhsCands s = M.toList $ M.fromList $ map cnd ks-      where-        ks          = predKs . F.crhs $ c-        cnd :: (F.KVar, F.Subst, F.TyVarSubst) -> (F.KVar , Sol.Cand Sol.EQual)-        cnd (k, su, tvsu) = (k, S.qbPreds su tvsu (Sol.lookupQBind s k))+    _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) -predKs :: F.Expr -> [(F.KVar, F.Subst, F.TyVarSubst)]+rhsCands :: Sol.Solution -> 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)++predKs :: F.Expr -> [(F.KVar, F.Subst)] predKs (F.PAnd ps)    = concatMap predKs ps-predKs (F.PKVar k tvsu su) = [(k, F.substFromKSubst su, tvsu)]+predKs (F.PKVar k su) = [(k, su)] predKs _              = []  --------------------------------------------------------------------------------@@ -286,66 +205,48 @@   :: (F.Fixpoint a, F.Loc a, NFData a)   => F.IBindEnv   -> Config-  -> F.SInfo a-  -> [F.SimpC a]+  -> W.Worklist a   -> Sol.Solution-  -> SolveM a (F.Result (Integer, a))+  -> SolveM (F.Result (Integer, a)) ---------------------------------------------------------------------------------result bindingsInSmt cfg fi cs s =-  sendConcreteBindingsToSMT bindingsInSmt be $ \bindingsInSmt2 -> do-    lift       $ writeLoud "Computing Result"-    stat      <- result_ bindingsInSmt2 be cfg cs s-    lift       $ whenLoud $ putStrLn $ "RESULT: " ++ show (F.sid <$> stat)-    resCut    <- solResult cfg s-    let resNonCut = S.nonCutsResult cfg be s-        resSorts = resultSorts fi (M.keys resCut ++ M.keys resNonCut) be-    return     $ F.Result (ci <$> stat) resCut resNonCut resSorts-  where-    ci c = (F.subcId c, F.sinfo c)-    be = F.bs fi--resultSorts :: F.SInfo a -> [F.KVar] -> F.BindEnv a -> F.ResultSorts-resultSorts fi ks be = M.fromList-  [(k, xts)-    | k <- ks-    , xts <- maybeToList (kvarScope fi be k) ]--kvarScope :: F.SInfo a -> F.BindEnv a -> F.KVar -> Maybe [(F.Symbol, F.Sort)]-kvarScope fi be k = do-  w <- M.lookup k (F.ws fi)-  let bs = F.wenv w-  let (v, t, _) = F.wrft w-  return $ (v, t) : [ bindInfo be i | i <- L.sort (F.elemsIBindEnv bs) ]+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) -bindInfo :: F.BindEnv a -> F.BindId -> (F.Symbol, F.Sort)-bindInfo be i = (x, F.sr_sort sr)+    F.Result (ci <$> stat) <$> solResult cfg s <*> solNonCutsResult s <*> return mempty   where-    (x, sr, _) = F.lookupBindEnv i be+    ci c = (F.subcId c, F.sinfo c) -solResult :: Config -> Sol.Solution -> SolveM ann (M.HashMap F.KVar F.Expr)+solResult :: Config -> Sol.Solution -> SolveM (M.HashMap F.KVar F.Expr) solResult cfg = minimizeResult cfg . Sol.result +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-  -> F.BindEnv a   -> Config-  -> [F.SimpC a]+  -> W.Worklist a   -> Sol.Solution-  -> SolveM a (F.FixResult (F.SimpC a))-result_ bindingsInSmt be cfg cs0 s = do-  unsatisfiedConstraints <- filterM (isUnsat bindingsInSmt be s) cs+  -> SolveM (F.FixResult (F.SimpC a))+result_ bindingsInSmt cfg w s = do+  filtered <- filterM (isUnsat bindingsInSmt s) cs   sts      <- stats-  pure $ res sts unsatisfiedConstraints+  pure $ res sts filtered   where-    cs          = isChecked cfg cs0+    cs          = isChecked cfg (W.unsatCandidates w)     res sts []  = F.Safe sts     res sts cs' = F.Unsafe sts cs'  isChecked :: Config -> [F.SimpC a] -> [F.SimpC a]-isChecked cfg cs = case checkCstr cfg of-  []   -> cs-  ids  -> let s = S.fromList ids in+isChecked cfg cs = case checkCstr cfg of +  []   -> cs +  ids  -> let s = S.fromList ids in            [c | c <- cs, S.member (F.subcId c) s ]  --------------------------------------------------------------------------------@@ -359,13 +260,13 @@ --   see: tests/pos/min00.fq for an example. -------------------------------------------------------------------------------- minimizeResult :: Config -> M.HashMap F.KVar F.Expr-               -> SolveM ann (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 ann F.Expr+minimizeConjuncts :: F.Expr -> SolveM F.Expr minimizeConjuncts p = F.pAnd <$> go (F.conjuncts p) []   where     go []     acc   = return acc@@ -375,14 +276,14 @@  -------------------------------------------------------------------------------- isUnsat-  :: (F.Loc a, NFData a) => F.IBindEnv -> F.BindEnv a -> Sol.Solution -> F.SimpC a -> SolveM a Bool+  :: (F.Loc a, NFData a) => F.IBindEnv -> Sol.Solution -> F.SimpC a -> SolveM Bool ---------------------------------------------------------------------------------isUnsat bindingsInSmt be s c = do+isUnsat bindingsInSmt s c = do   -- lift   $ printf "isUnsat %s" (show (F.subcId c))   _     <- tickIter True -- newScc-  cfg <- T.config <$> getContext-  let lp = S.lhsPred cfg bindingsInSmt be s c-      rp = rhsPred c+  be    <- getBinds+  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   return res@@ -403,9 +304,9 @@   | otherwise  = errorstar $ "rhsPred on non-target: " ++ show (F.sid c)  ---------------------------------------------------------------------------------isValid :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM ann Bool+isValid :: F.SrcSpan -> F.Expr -> F.Expr -> SolveM Bool ---------------------------------------------------------------------------------isValid sp p q = not . null <$> filterValid sp p [(q, ())]+isValid sp p q = (not . null) <$> filterValid sp p [(q, ())]  cstrSpan :: (F.Loc a) => F.SimpC a -> F.SrcSpan cstrSpan = F.srcSpan . F.sinfo@@ -419,3 +320,49 @@   putBlankLn   donePhase Loud msg -}+++-- NV TODO Move to a new file+-------------------------------------------------------------------------------+-- | Interaction with the user when Solving -----------------------------------+-------------------------------------------------------------------------------++_iMergePartitions :: [(Int, F.SInfo a)] -> IO [(Int, F.SInfo a)]+_iMergePartitions ifis = do+  putStrLn "Current Partitions are: "+  putStrLn $ unlines (partitionInfo <$> ifis)+  putStrLn "Merge Partitions? Y/N"+  c <- getChar+  if c == 'N'+    then do putStrLn "Solving Partitions"+            return ifis+    else do+      (i, j) <- getMergePartition (length ifis)+      _iMergePartitions (mergePartitions i j ifis)++getMergePartition :: Int -> IO (Int, Int)+getMergePartition n = do+  putStrLn "Which two partition to merge? (i, j)"+  ic <- getLine+  let (i,j) = read ic :: (Int, Int)+  if i < 1 || n < i || j < 1 || n < j+    then do putStrLn ("Invalid Partition numbers, write (i,j) with 1 <= i <= " ++ show n)+            getMergePartition n+    else return (i,j)++mergePartitions :: Int -> Int -> [(Int, F.SInfo a)] -> [(Int, F.SInfo a)]+mergePartitions i j fis+  = zip [1..] ((takei i `mappend` (takei j){F.bs = mempty}):rest)+  where+    takei i = snd (fis L.!! (i - 1))+    rest = snd <$> filter (\(k,_) -> (k /= i && k /= j)) fis++partitionInfo :: (Int, F.SInfo a) -> String+partitionInfo (i, fi)+  = "Partition number " ++ show i ++ "\n" +++    "Defined ?? " ++ show defs    ++ "\n" +++    "Used ?? "    ++ show uses+  where+    gs   = F.wloc . snd <$> L.filter (F.isGWfc . snd) (M.toList (F.ws fi))+    defs = L.nub (F.gsrc <$> gs)+    uses = L.nub (F.gused <$> gs)
src/Language/Fixpoint/Solver/Stats.hs view
@@ -14,7 +14,11 @@ import qualified Language.Fixpoint.Types.PrettyPrint as F import Data.Aeson -data Stats = Stats+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif++data Stats = Stats    { numCstr      :: !Int -- ^ # Horn Constraints   , numIter      :: !Int -- ^ # Refine Iterations   , numBrkt      :: !Int -- ^ # smtBracket    calls (push/pop)@@ -35,7 +39,7 @@                         ]  instance Semigroup Stats where-  s1 <> s2 =+  s1 <> s2 =      Stats { numCstr      = numCstr s1      + numCstr s2           , numIter      = numIter s1      + numIter s2           , numBrkt      = numBrkt s1      + numBrkt s2
src/Language/Fixpoint/Solver/TrivialSort.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE CPP           #-} {-# LANGUAGE DeriveGeneric #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-}- module Language.Fixpoint.Solver.TrivialSort (nontrivsorts) where  import           GHC.Generics        (Generic)@@ -15,9 +12,7 @@ import qualified Data.HashSet            as S import           Data.Hashable import qualified Data.HashMap.Strict     as M-#if !MIN_VERSION_base(4,20,0) import           Data.List (foldl')-#endif import qualified Data.Graph              as G import           Data.Maybe import           Text.Printf@@ -89,10 +84,10 @@ updTISubC :: SubC a -> TrivInfo -> TrivInfo updTISubC c = updTI Lhs (slhs c) . updTI Rhs (srhs c) -updTIBinds :: BindEnv a -> TrivInfo -> TrivInfo+updTIBinds :: BindEnv -> TrivInfo -> TrivInfo updTIBinds be ti = foldl' (flip (updTI Lhs)) ti ts   where-    ts           = [t | (_, (_,t,_)) <- bindEnvToList be]+    ts           = [t | (_,_,t) <- bindEnvToList be]  -------------------------------------------------------------------- updTI :: Polarity -> SortedReft -> TrivInfo -> TrivInfo@@ -127,8 +122,8 @@     trivOrSingP p         = trivP p || singP v p  trivP :: Expr -> Bool-trivP PKVar {} = True-trivP p        = isTautoPred p+trivP (PKVar {}) = True+trivP p          = isTautoPred p  singP :: Symbol -> Expr -> Bool singP v (PAtom Eq (EVar x) _)@@ -146,8 +141,8 @@    , bs   = simplifyBindEnv tm $ bs fi } -simplifyBindEnv :: NonTrivSorts -> BindEnv a -> BindEnv a-simplifyBindEnv tm = mapBindEnv (\_ (x, sr, a) -> (x, simplifySortedReft tm sr, a))+simplifyBindEnv :: NonTrivSorts -> BindEnv -> BindEnv+simplifyBindEnv tm = mapBindEnv (\_ (x, sr) -> (x, simplifySortedReft tm sr))  simplifyWfCs :: NonTrivSorts -> M.HashMap KVar (WfC a) -> M.HashMap KVar (WfC a) simplifyWfCs tm = M.filter (isNonTrivialSort tm . snd3 . wrft)@@ -173,7 +168,7 @@ simplifySortedReft :: NonTrivSorts -> SortedReft -> SortedReft simplifySortedReft tm sr   | nonTrivial = sr-  | otherwise  = sr { sr_reft = trueReft }+  | otherwise  = sr { sr_reft = mempty }   where     nonTrivial = isNonTrivialSort tm (sr_sort sr)
src/Language/Fixpoint/Solver/UniqifyBinds.hs view
@@ -1,40 +1,36 @@-{-# LANGUAGE CPP           #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-}- -- This module makes it so no binds with different sorts have the same name.  module Language.Fixpoint.Solver.UniqifyBinds (renameAll) where  import           Language.Fixpoint.Types import           Language.Fixpoint.Solver.Sanitize (dropDeadSubsts)-import           Language.Fixpoint.Misc          (fst3, mlookup, snd3)+import           Language.Fixpoint.Misc          (fst3, mlookup)  import qualified Data.HashMap.Strict as M import qualified Data.HashSet        as S import qualified Data.List           as L-#if !MIN_VERSION_base(4,20,0) import           Data.Foldable       (foldl')-#endif-import           Data.Maybe          (catMaybes, mapMaybe, fromJust, isJust)+import           Data.Maybe          (catMaybes, fromJust, isJust) import           Data.Hashable       (Hashable) import           GHC.Generics        (Generic)+import           Control.Arrow       (second) import           Control.DeepSeq     (NFData, ($!!)) -- import Debug.Trace (trace)  ---------------------------------------------------------------------------------renameAll    :: (NFData a) => SInfo a -> SInfo a+renameAll    :: SInfo a -> SInfo a -------------------------------------------------------------------------------- renameAll fi2 = fi6   where-    fi6       = {- SCC "dropDead"    -} dropDeadSubsts  fi5-    fi5       = {- SCC "dropUnused"  -} dropUnusedBinds fi4-    fi4       = {- SCC "renameBinds" -} renameBinds fi3 $!! rnm-    fi3       = {- SCC "renameVars"  -} renameVars fi2 rnm $!! idm-    rnm       = {- SCC "mkRenameMap" -} mkRenameMap $!! bs fi2-    idm       = {- SCC "mkIdMap"     -} mkIdMap fi2+    fi6       = {- SCC "dropDead"    #-} dropDeadSubsts  fi5+    fi5       = {- SCC "dropUnused"  #-} dropUnusedBinds fi4+    fi4       = {- SCC "renameBinds" #-} renameBinds fi3 $!! rnm+    fi3       = {- SCC "renameVars"  #-} renameVars fi2 rnm $!! idm+    rnm       = {- SCC "mkRenameMap" #-} mkRenameMap $!! bs fi2+    idm       = {- SCC "mkIdMap"     #-} mkIdMap fi2   --------------------------------------------------------------------------------@@ -47,7 +43,7 @@     -- _tx i (x, r)     -- | isUsed i    = (x, r)     -- | otherwise   = (x, top r)-    isUsed i _x r  = memberIBindEnv i usedBinds || isTautoReft (sr_reft r)+    isUsed i _x r  = {- tracepp (unwords ["isUsed", show i, showpp _x]) $ -} memberIBindEnv i usedBinds || isTauto r     usedBinds      = L.foldl' unionIBindEnv emptyIBindEnv (cEnvs ++ wEnvs)     wEnvs          = wenv <$> M.elems (ws fi)     cEnvs          = senv <$> M.elems (cm fi)@@ -75,19 +71,19 @@ -------------------------------------------------------------------------------- mkIdMap fi = M.foldlWithKey' (updateIdMap $ bs fi) M.empty $ cm fi -updateIdMap :: BindEnv a -> IdMap -> Integer -> SimpC a -> IdMap+updateIdMap :: BindEnv -> IdMap -> Integer -> SimpC a -> IdMap updateIdMap be m scId s = M.insertWith S.union (RI scId) refSet m'   where     ids                 = elemsIBindEnv (senv s)-    nameMap             = M.fromList [(fst3 $ lookupBindEnv i be, i) | i <- ids]+    nameMap             = M.fromList [(fst $ lookupBindEnv i be, i) | i <- ids]     m'                  = foldl' (insertIdIdLinks be nameMap) m ids     symSet              = S.fromList $ syms $ crhs s     refSet              = namesToIds symSet nameMap -insertIdIdLinks :: BindEnv a -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap+insertIdIdLinks :: BindEnv -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap insertIdIdLinks be nameMap m i = M.insertWith S.union (RB i) refSet m   where-    sr     = snd3 $ lookupBindEnv i be+    sr     = snd $ lookupBindEnv i be     symSet = reftFreeVars $ sr_reft sr     refSet = namesToIds symSet nameMap @@ -95,19 +91,18 @@ namesToIds xs m = S.fromList $ catMaybes [M.lookup x m | x <- S.toList xs] --TODO why any Nothings?  ---------------------------------------------------------------------------------mkRenameMap :: BindEnv a -> RenameMap+mkRenameMap :: BindEnv -> RenameMap -------------------------------------------------------------------------------- mkRenameMap be = foldl' (addId be) M.empty ids   where-    ids = fst <$> bindEnvToList be+    ids = fst3 <$> bindEnvToList be -addId :: BindEnv a -> RenameMap -> BindId -> RenameMap+addId :: BindEnv -> RenameMap -> BindId -> RenameMap addId be m i   | M.member sym m = addDupId m sym t i   | otherwise      = M.insert sym [(t, Nothing)] m   where-    t              = sr_sort sr-    (sym, sr, _)   = lookupBindEnv i be+    (sym, t)       = second sr_sort $ lookupBindEnv i be  addDupId :: RenameMap -> Symbol -> Sort -> BindId -> RenameMap addDupId m sym t i@@ -127,9 +122,8 @@ updateRef :: RenameMap -> SInfo a -> Ref -> S.HashSet BindId -> SInfo a updateRef rnMap fi rf bset = applySub (mkSubst subs) fi rf   where-    symTList = [ (sym, sr_sort sr) | i <- S.toList bset, let (sym, sr, _) = lookupBindEnv i bEnv]-    bEnv     = bs fi-    subs     = mapMaybe (mkSubUsing rnMap) symTList+    symTList = [second sr_sort $ lookupBindEnv i $ bs fi | i <- S.toList bset]+    subs     = catMaybes $ mkSubUsing rnMap <$> symTList  mkSubUsing :: RenameMap -> (Symbol, Sort) -> Maybe (Symbol, Expr) mkSubUsing m (sym, t) = do@@ -150,12 +144,12 @@ -------------------------------------------------------------------------------- renameBinds fi m = fi { bs = bindEnvFromList $ renameBind m <$> beList }   where-    beList       = bindEnvToList (bs fi)+    beList       = bindEnvToList $ bs fi -renameBind :: RenameMap -> (BindId, (Symbol, SortedReft, a)) -> (BindId, (Symbol, SortedReft, a))-renameBind m (i, (sym, sr, ann))-  | Just newSym <- mnewSym = (i, (newSym, sr, ann))-  | otherwise              = (i, (sym,    sr, ann))+renameBind :: RenameMap -> (BindId, Symbol, SortedReft) -> (BindId, Symbol, SortedReft)+renameBind m (i, sym, sr)+  | Just newSym <- mnewSym = (i, newSym, sr)+  | otherwise              = (i, sym,    sr)   where     t                      = sr_sort sr     mnewSym                = fromJust $ L.lookup t $ mlookup m sym
src/Language/Fixpoint/Solver/UniqifyKVars.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE ViewPatterns           #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}- {- | This module creates new bindings for each argument of each kvar.      It also makes sure that all arguments to each kvar are explicit. @@ -40,10 +36,7 @@ import           Language.Fixpoint.Types import           Language.Fixpoint.Types.Visitor (mapKVarSubsts) import qualified Data.HashMap.Strict as M-import qualified Data.List as L-#if !MIN_VERSION_base(4,20,0) import           Data.Foldable       (foldl')-#endif  -------------------------------------------------------------------------------- wfcUniqify    :: SInfo a -> SInfo a@@ -57,14 +50,14 @@ -------------------------------------------------------------------------------- remakeSubsts fi = mapKVarSubsts (remakeSubst fi) fi -remakeSubst :: SInfo a -> KVar -> KVarSubst Symbol Symbol -> KVarSubst Symbol Symbol+remakeSubst :: SInfo a -> KVar -> Subst -> Subst remakeSubst fi k su = foldl' (updateSubst k) su (kvarDomain fi k) -updateSubst :: KVar -> KVarSubst Symbol Symbol -> Symbol -> KVarSubst Symbol Symbol-updateSubst k (fromKVarSubst -> su) sym+updateSubst :: KVar -> Subst -> Symbol -> Subst+updateSubst k (Su su) sym   = case M.lookup sym su of-      Just z  -> toKVarSubst $ M.delete sym $ M.insert ksym z          su-      Nothing -> toKVarSubst $                M.insert ksym (eVar sym) su+      Just z  -> Su $ M.delete sym $ M.insert ksym z          su+      Nothing -> Su $                M.insert ksym (eVar sym) su     where       kx      = kv k       ksym    = kArgSymbol sym kx@@ -80,32 +73,33 @@ updateWfc :: SInfo a -> WfC a -> SInfo a updateWfc fi w    = fi'' { ws = M.insert k w' (ws fi) }   where-    w'           = w { wenv = insertsIBindEnv newIds mempty, wrft = (v', t, k) }-    (_, fi'')     = newTopBind v' (trueSortedReft t) a fi'-    (fi', newIds) = foldl' (accumBindsIfValid k a) (fi, []) (L.sort $ elemsIBindEnv $ wenv w)+    w'            = updateWfCExpr (subst su) w''+    w''           = w { wenv = insertsIBindEnv newIds mempty, wrft = (v', t, k) }+    (_, fi'')     = newTopBind v' (trueSortedReft t) fi'+    (fi', newIds) = foldl' (accumBindsIfValid k) (fi, []) (elemsIBindEnv $ wenv w)     (v, t, k)     = wrft w     v'            = kArgSymbol v (kv k)-    a             = winfo w+    su            = mkSubst ((v, EVar v'):[(x, eVar $ kArgSymbol x (kv k)) | x <- kvarDomain fi k]) -accumBindsIfValid :: KVar -> a -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])-accumBindsIfValid k a (fi, ids) i = if renamable then accumBinds k a (fi, ids) i else (fi, i : ids)+accumBindsIfValid :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])+accumBindsIfValid k (fi, ids) i = if renamable then accumBinds k (fi, ids) i else (fi, i : ids)   where-    (_, sr, _)                    = lookupBindEnv i      (bs fi)+    (_, sr)                     = lookupBindEnv i      (bs fi)     renamable                   = isValidInRefinements (sr_sort sr) -accumBinds :: KVar -> a -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])-accumBinds k a (fi, ids) i = (fi', i' : ids)+accumBinds :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId])+accumBinds k (fi, ids) i = (fi', i' : ids)   where-    (oldSym, sr,_) = lookupBindEnv i (bs fi)+    (oldSym, sr) = lookupBindEnv i (bs fi)     newSym       = {- tracepp "kArgSymbol" $ -}  kArgSymbol oldSym (kv k)-    (i', fi')    = newTopBind newSym sr a fi+    (i', fi')    = newTopBind newSym sr fi  -- | `newTopBind` ignores the actual refinements as they are not relevant --   in the kvar parameters (as suggested by BLC.)-newTopBind :: Symbol -> SortedReft -> a -> SInfo a -> (BindId, SInfo a)-newTopBind x sr a fi = (i', fi {bs = be'})+newTopBind :: Symbol -> SortedReft -> SInfo a -> (BindId, SInfo a)+newTopBind x sr fi = (i', fi {bs = be'})   where-    (i', be')        = insertBindEnv x (sr {sr_reft = trueReft}) a (bs fi)+    (i', be')   = insertBindEnv x (top sr) (bs fi)  -------------------------------------------------------------- @@ -118,6 +112,5 @@ isValidInRefinements (FVar _)    = True isValidInRefinements (FFunc _ _) = True -- False isValidInRefinements (FAbs  _ t) = isValidInRefinements t-isValidInRefinements (FTC _)     = True -- TODO is this true? seems to be required for e.g. ResolvePred.hs+isValidInRefinements (FTC _)     = True --TODO is this true? seems to be required for e.g. ResolvePred.hs isValidInRefinements (FApp _ _)  = True-isValidInRefinements (FNatNum _) = True -- TODO probably?
src/Language/Fixpoint/Solver/Worklist.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE TupleSections         #-}  module Language.Fixpoint.Solver.Worklist        ( -- * Worklist type is opaque@@ -24,8 +25,8 @@ import           Prelude hiding (init) import           Language.Fixpoint.Types.PrettyPrint import qualified Language.Fixpoint.Types   as F-import           Language.Fixpoint.Types.Visitor (isConcC) import           Language.Fixpoint.Graph.Types+import           Language.Fixpoint.Graph   (isTarget)  import           Control.Arrow             (first) import qualified Data.HashMap.Strict       as M@@ -87,7 +88,7 @@ -------------------------------------------------------------------------------- -- | Initialize worklist and slice out irrelevant constraints ------------------ ---------------------------------------------------------------------------------init :: SolverInfo a -> Worklist a+init :: SolverInfo a b -> Worklist a -------------------------------------------------------------------------------- init sI    = WL { wCs     = items                 , wPend   = addPends M.empty kvarCs@@ -104,11 +105,9 @@     cd        = siDeps sI     rankm     = cRank cd     items     = S.fromList $ workItemsAt rankm 0 <$> kvarCs-    concCs    = fst <$> filter (isNonTriv . snd) ics+    concCs    = fst <$> ics     kvarCs    = fst <$> iks-    (ics,iks) = L.partition (isConcC . snd) (M.toList cm)--    isNonTriv = not .  F.isTautoPred . F.crhs+    (ics,iks) = L.partition (isTarget . snd) (M.toList cm)  --------------------------------------------------------------------------- -- | Candidate Constraints to be checked AFTER computing Fixpoint ---------
src/Language/Fixpoint/SortCheck.hs view
@@ -1,1728 +1,1400 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE Strict                #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PatternGuards         #-}-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE InstanceSigs #-}---- | This module has the functions that perform sort-checking, and related--- operations on Fixpoint expressions and predicates.--module Language.Fixpoint.SortCheck  (-  -- * Sort Substitutions-    TVSubst-  , Env-  , mkSearchEnv-  , globalEnv-  , theoryEnv--  -- * Checking Well-Formedness-  , checkSorted-  , checkSortedReft-  , checkSortedReftFull-  , checkSortFull-  , pruneUnsortedReft--  -- * Sort inference-  , sortExpr-  , checkSortExpr-  , exprSort-  , exprSortMaybe--  -- * Unify-  , unifyFast-  , unifySorts-  , unifyTo1-  , unifys--  -- * Apply Substitution-  , apply-  , defuncEApp--  -- * Exported Sorts-  , boolSort-  , strSort--  -- * Sort-Directed Transformations-  , ElabM-  , ElabParam (..)-  , Elaborate (..)-  , applySorts-  , elabApply-  , elabExpr-  , elabNumeric-  , unApply-  , unElab-  , unElabFSetBagZ3-  , unElabSortedReft-  , unApplySortedReft-  , unApplyAt-  , toInt--  -- * Predicates on Sorts-  , isFirstOrder-  , isMono----  , runCM0-  ) where----  import           Control.DeepSeq-import           Control.Exception (Exception, catch, try, throwIO)-import           Control.Monad-import           Control.Monad.Reader--import           Data.Bifunctor (first, second)-import qualified Data.IntMap.Strict       as M-import qualified Data.HashSet              as S-import           Data.IORef-import qualified Data.List                 as L-import           Data.Maybe                (mapMaybe, fromMaybe, isJust)-import qualified Data.HashMap.Strict       as HashMap-import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types hiding   (subst, GInfo(..), senv)-import qualified Language.Fixpoint.Types.Config as Cfg-import qualified Language.Fixpoint.Types.Visitor  as Vis-import qualified Language.Fixpoint.Smt.Theories   as Thy-import           Text.PrettyPrint.HughesPJ.Compat-import           Text.Printf--import           GHC.Stack-import qualified Language.Fixpoint.Types as F-import           System.IO.Unsafe (unsafePerformIO)-import Language.Fixpoint.Types.Config (ElabFlags(elabExplicitKvars))----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 -----------------------------------------------------------------------------------------------------------------------------------------isMono :: Sort -> Bool----------------------------------------------------------------------------------isMono             = null . Vis.foldSort fv []-  where-    fv vs (FVar i) = i : vs-    fv vs _        = vs-------------------------------------------------------------------------------------- | Elaborate: make polymorphic instantiation explicit via casts,---   make applications monomorphic for SMTLIB. This deals with---   polymorphism by `elaborate`-ing all refinements except for---   KVars. THIS IS NOW MANDATORY as sort-variables can be---   instantiated to `int` and `bool`.-----------------------------------------------------------------------------------type ElabM = Reader Cfg.ElabFlags--data ElabParam = ElabParam-  { epFlags :: Cfg.ElabFlags-  , epMsg   :: Located String-  , epEnv   :: SymEnv-  }--class Elaborate a where-  elaborate :: HasCallStack => ElabParam -> a -> a---instance (Loc a) => Elaborate (SInfo a) where-  elaborate ep si = si-    { F.cm      = elaborate ep <$> F.cm      si-    , F.bs      = elaborate ep  $  F.bs      si-    , F.gLits   = coerceSort (epFlags ep) <$> F.gLits   si-    , F.dLits   = coerceSort (epFlags ep) <$> F.dLits   si-    , F.asserts = elaborate ep <$> F.asserts si-    , F.defns   = elaborate ep  $ F.defns    si-    , F.ddecls  = coerceDataDecl (epFlags ep) <$> F.ddecls si-    }---instance (Elaborate e) => (Elaborate (Triggered e)) where-  elaborate ep t = elaborate ep <$> t--instance (Elaborate a) => (Elaborate (Maybe a)) where-  elaborate ep t = elaborate ep <$> t--instance Elaborate Sort where-  elaborate ep =  coerceSort (epFlags ep) . go-   where-      go s | isString s = strSort-      go (FAbs i s)    = FAbs i  (go s)-      go (FFunc s1 s2) = funSort (go s1) (go s2)-      go (FApp s1 s2)  = FApp    (go s1) (go s2)-      go s             = s-      funSort :: Sort -> Sort -> Sort-      funSort = FApp . FApp funcSort--instance Elaborate AxiomEnv where-  elaborate ep ae = ae-    { aenvEqs   = elaborate ep (aenvEqs ae)-    -- MISSING SORTS OOPS, aenvSimpl = elaborate msg env (aenvSimpl ae)-    }--instance Elaborate Rewrite where-  elaborate ep rw = rw { smBody = skipElabExpr ep' (smBody rw) }-    where-      ep' = ep { epEnv = insertsSymEnv (epEnv ep) undefined }---instance Elaborate Equation where-  elaborate ep eq = eq { eqBody = skipElabExpr ep' (eqBody eq) }-    where-      ep' = ep { epEnv = insertsSymEnv (epEnv ep) (eqArgs eq) }---instance Elaborate DefinedFuns where-  elaborate ep (MkDefinedFuns eqs) = MkDefinedFuns (elabDefinedEqn ep <$> eqs)--elabDefinedEqn :: ElabParam -> Equation -> Equation-elabDefinedEqn ep eq = eq { eqBody = elaborateExpr ep' (eqBody eq) (Just t')-                          , eqArgs = [(x, tx t) | (x, t) <- eqArgs eq ]-                          , eqSort = t'-                          }-  where-    ep' = ep { epEnv = insertsSymEnv (epEnv ep) (eqArgs eq) }-    tx  = coerceSort (epFlags ep)-    t'  = tx (eqSort eq)--instance Elaborate Expr where-  elaborate p e = elaborateExpr p e Nothing--elaborateExpr :: HasCallStack => ElabParam -> Expr -> Maybe Sort -> Expr-elaborateExpr (ElabParam ef msg env) e t =-  elabNumeric env' . elabApply env' . elabExpr (ElabParam ef msg env') t .  elabSorts ef . elabFMap . (if Cfg.elabSetBag ef then elabFSetBagZ3 else id) $ e-    where-      env' = coerceEnv ef env--skipElabExpr :: ElabParam -> Expr -> Expr-skipElabExpr ep e = case elabExprE ep Nothing e of-  Left _   -> e-  Right e' -> elabNumeric (epEnv ep) . elabApply (epEnv ep) $ e'--instance Elaborate (Symbol, Sort) where-  elaborate ep (x, s) = (x, elaborate ep s)--instance Elaborate a => Elaborate [a]  where-  elaborate ep xs = elaborate ep <$> xs--elabNumeric :: SymEnv -> Expr -> Expr-elabNumeric env = Vis.mapExprOnExpr go-  where-    go (ETimes e1 e2)-      | isFractional env (exprSort ("txn3: " ++ showpp e1) e1)-      , isFractional env (exprSort "txn4" e2)-      = ERTimes e1 e2-    go (EDiv   e1 e2)-      | isFractional env (exprSort ("txn3: " ++ showpp e1) e1)-      , isFractional env (exprSort "txn4" e2)-      = ERDiv e1 e2-    go e-      = e--instance Elaborate SortedReft where-  elaborate ep (RR s (Reft (v, e))) = RR (coerceSort (epFlags ep) s) (Reft (v, e'))-    where-      e'   = elaborateExpr ep' e (Just boolSort) -- check that a SortedReft is in fact a bool-      ep' = ep { epEnv = insertSymEnv v s (epEnv ep) }--instance (Loc a) => Elaborate (BindEnv a) where-  elaborate ep = mapBindEnv (\i (x, sr, l) -> (x, elaborate (ep { epMsg = msg' l i x sr }) sr, l))-    where-      msg' l i x sr = atLoc l (val (epMsg ep) ++ unwords [" elabBE", show i, show x, show sr])--instance (Loc a) => Elaborate (SimpC a) where-  elaborate ep c = c {_crhs = elaborate ep' (_crhs c) }-    where-      ep' = ep { epMsg = atLoc c (val $ epMsg ep) }---------------------------------------------------------------------------------------- | Replace all finset/finmap/finbag theory operations with array-based encodings.---------------------------------------------------------------------------------------- TODO abstract into a visitor for EApp?---- TODO there's no actual elaboration happening here, just symbol renaming-elabFMap :: Expr -> Expr-elabFMap (EApp h@(EVar f) e)-  | f == Thy.mapDef        = EApp (EVar Thy.arrConstM) (elabFMap e)-  | otherwise              = EApp (elabFMap h) (elabFMap e)-elabFMap (EApp (EApp h@(EVar f) e1) e2)-  | f == Thy.mapSel        = EApp (EApp (EVar Thy.arrSelectM) (elabFMap e1)) (elabFMap e2)-  | otherwise              = EApp (EApp (elabFMap h) (elabFMap e1)) (elabFMap e2)-elabFMap (EApp (EApp (EApp h@(EVar f) e1) e2) e3)-  | f == Thy.mapSto        = EApp (EApp (EApp (EVar Thy.arrStoreM) (elabFMap e1)) (elabFMap e2)) (elabFMap e3)-  | otherwise              = EApp (EApp (EApp (elabFMap h) (elabFMap e1)) (elabFMap e2)) (elabFMap e3)-elabFMap (EApp e1 e2)      = EApp (elabFMap e1) (elabFMap e2)-elabFMap (ENeg e)          = ENeg (elabFMap e)-elabFMap (EBin b e1 e2)    = EBin b (elabFMap e1) (elabFMap e2)-elabFMap (ELet x e1 e2)    = ELet x (elabFMap e1) (elabFMap e2)-elabFMap (EIte e1 e2 e3)   = EIte (elabFMap e1) (elabFMap e2) (elabFMap e3)-elabFMap (ECst e t)        = ECst (elabFMap e) t-elabFMap (ELam b e)        = ELam b (elabFMap e)-elabFMap (ETApp e t)       = ETApp (elabFMap e) t-elabFMap (ETAbs e t)       = ETAbs (elabFMap e) t-elabFMap (PAnd es)         = PAnd (elabFMap <$> es)-elabFMap (POr es)          = POr (elabFMap <$> es)-elabFMap (PNot e)          = PNot (elabFMap e)-elabFMap (PImp e1 e2)      = PImp (elabFMap e1) (elabFMap e2)-elabFMap (PIff e1 e2)      = PIff (elabFMap e1) (elabFMap e2)-elabFMap (PAtom r e1 e2)   = PAtom r (elabFMap e1) (elabFMap e2)-elabFMap (PAll   bs e)     = PAll bs (elabFMap e)-elabFMap (PExist bs e)     = PExist bs (elabFMap e)-elabFMap (ECoerc a t e)    = ECoerc a t (elabFMap e)-elabFMap (PKVar k tsu su)      = PKVar k tsu (mapKVarSubst elabFMap su)-elabFMap e                 = e---elabFSetBagZ3 :: Expr -> Expr-elabFSetBagZ3 = go-  where-    go (EApp h@(EVar f) e)-      | f == Thy.setEmpty = EApp (EVar Thy.arrConstS) PFalse-      | f == Thy.setEmp   = PAtom Eq (EApp (EVar Thy.arrConstS) PFalse) (go e)-      | f == Thy.setSng   = EApp (EApp (EApp (EVar Thy.arrStoreS) (EApp (EVar Thy.arrConstS) PFalse)) (go e)) PTrue-      | f == Thy.setCom   = EApp (EVar Thy.arrMapNotS) (go e)-      | f == Thy.bagEmpty = EApp (EVar Thy.arrConstB) (ECon (I 0))-      | otherwise         = EApp (go h) (go e)-    go (EApp (EApp h@(EVar f) e1) e2)-      | f == Thy.setMem   = EApp (EApp (EVar Thy.arrSelectS) (go e2)) (go e1)-      | f == Thy.setCup   = EApp (EApp (EVar Thy.arrMapOrS) (go e1)) (go e2)-      | f == Thy.setCap   = EApp (EApp (EVar Thy.arrMapAndS) (go e1)) (go e2)-      | f == Thy.setAdd   = EApp (EApp (EApp (EVar Thy.arrStoreS) (go e2)) (go e1)) PTrue-      -- A \ B == A /\ ~B == ~(A => B)-      | f == Thy.setDif   = EApp (EApp (EVar Thy.arrMapAndS) (go e1)) (EApp (EVar Thy.arrMapNotS) (go e2))-      | f == Thy.setSub   = PAtom Eq (EApp (EVar Thy.arrConstS) PTrue) (EApp (EApp (EVar Thy.arrMapImpS) (go e1)) (go e2))-      | f == Thy.bagCount = EApp (EApp (EVar Thy.arrSelectB) (go e2)) (go e1)-      | f == Thy.bagSng   = EApp (EApp (EApp (EVar Thy.arrStoreB) (EApp (EVar Thy.arrConstB) (ECon (I 0)))) (go e1)) (go e2)-      | f == Thy.bagCup   = EApp (EApp (EVar Thy.arrMapPlusB) (go e1)) (go e2)-      | f == Thy.bagSub   = PAtom Eq (EApp (EVar Thy.arrConstS) PTrue) (EApp (EApp (EVar Thy.arrMapLeB) (go e1)) (go e2))-      | f == Thy.bagMax   = EApp (EApp (EApp (EVar Thy.arrMapIteB) (EApp (EApp (EVar Thy.arrMapGtB) (go e1)) (go e2))) (go e1)) (go e2)-      | f == Thy.bagMin   = EApp (EApp (EApp (EVar Thy.arrMapIteB) (EApp (EApp (EVar Thy.arrMapLeB) (go e1)) (go e2))) (go e1)) (go e2)-      | otherwise         = EApp (EApp (go h) (go e1)) (go e2)-    go (EApp e1 e2)       = EApp   (go e1) (go e2)-    go (ENeg e)           = ENeg   (go e)-    go (EBin b e1 e2)     = EBin b (go e1) (go e2)-    go (ELet x e1 e2)     = ELet x (go e1) (go e2)-    go (EIte e1 e2 e3)    = EIte   (go e1) (go e2) (go e3)-    go (ECst e t)         = ECst   (go e) t-    go (ELam b e)         = ELam b (go e)-    go (ETApp e t)        = ETApp  (go e) t-    go (ETAbs e t)        = ETAbs  (go e) t-    go (PAnd es)          = PAnd   (go <$> es)-    go (POr es)           = POr    (go <$> es)-    go (PNot e)           = PNot   (go e)-    go (PImp e1 e2)       = PImp   (go e1) (go e2)-    go (PIff e1 e2)       = PIff   (go e1) (go e2)-    go (PAtom r e1 e2)    = PAtom r (go e1) (go e2)-    go (PAll   bs e)      = PAll bs (go e)-    go (PExist bs e)      = PExist bs (go e)-    go (ECoerc a t e)     = ECoerc a t (go e)-    go (PKVar k tsu su)       = PKVar k tsu (mapKVarSubst go su)-    go e                  = e---- | Reverse transformation of elabFSetBagZ3: converts array representations back to set/bag operations-unElabFSetBagZ3 :: Expr -> Expr-unElabFSetBagZ3 = go-  where-    -- arr_const_s false -> Set_empty-    go (EApp (EVar f) PFalse)-      | f == Thy.arrConstS = EVar Thy.setEmpty-    -- arr_const_s false == e -> Set_emp e-    go (PAtom Eq (EApp (EVar f) PFalse) e)-      | f == Thy.arrConstS = EApp (EVar Thy.setEmp) (go e)-    -- arr_store_s (arr_const_s false) e true -> Set_sng e-    go (EApp (EApp (EApp (EVar f1) (EApp (EVar f2) PFalse)) e) PTrue)-      | f1 == Thy.arrStoreS && f2 == Thy.arrConstS = EApp (EVar Thy.setSng) (go e)-    -- arr_map_not_s e -> Set_com e-    go (EApp (EVar f) e)-      | f == Thy.arrMapNotS = EApp (EVar Thy.setCom) (go e)-    -- arr_const_b 0 -> Bag_empty-    go (EApp (EVar f) (ECon (I 0)))-      | f == Thy.arrConstB = EVar Thy.bagEmpty-    -- arr_select_s e2 e1 -> Set_mem e1 e2-    go (EApp (EApp (EVar f) e2) e1)-      | f == Thy.arrSelectS = EApp (EApp (EVar Thy.setMem) (go e1)) (go e2)-    -- arr_map_or_s e1 e2 -> Set_cup e1 e2-    go (EApp (EApp (EVar f) e1) e2)-      | f == Thy.arrMapOrS = EApp (EApp (EVar Thy.setCup) (go e1)) (go e2)-    -- arr_map_and_s e1 e2 -> Set_cap e1 e2-    go (EApp (EApp (EVar f) e1) e2)-      | f == Thy.arrMapAndS = EApp (EApp (EVar Thy.setCap) (go e1)) (go e2)-    -- arr_store_s e2 e1 true -> Set_add e1 e2-    go (EApp (EApp (EApp (EVar f) e2) e1) PTrue)-      | f == Thy.arrStoreS = EApp (EApp (EVar Thy.setAdd) (go e1)) (go e2)-    -- arr_map_and_s e1 (arr_map_not_s e2) -> Set_dif e1 e2-    go (EApp (EApp (EVar f1) e1) (EApp (EVar f2) e2))-      | f1 == Thy.arrMapAndS && f2 == Thy.arrMapNotS = EApp (EApp (EVar Thy.setDif) (go e1)) (go e2)-    -- arr_const_s true == arr_map_imp_s e1 e2 -> Set_sub e1 e2-    go (PAtom Eq (EApp (EVar f1) PTrue) (EApp (EApp (EVar f2) e1) e2))-      | f1 == Thy.arrConstS && f2 == Thy.arrMapImpS = EApp (EApp (EVar Thy.setSub) (go e1)) (go e2)-    -- arr_select_b e2 e1 -> Bag_count e1 e2-    go (EApp (EApp (EVar f) e2) e1)-      | f == Thy.arrSelectB = EApp (EApp (EVar Thy.bagCount) (go e1)) (go e2)-    -- arr_store_b (arr_const_b 0) e1 e2 -> Bag_sng e1 e2-    go (EApp (EApp (EApp (EVar f1) (EApp (EVar f2) (ECon (I 0)))) e1) e2)-      | f1 == Thy.arrStoreB && f2 == Thy.arrConstB = EApp (EApp (EVar Thy.bagSng) (go e1)) (go e2)-    -- arr_map_plus_b e1 e2 -> Bag_cup e1 e2-    go (EApp (EApp (EVar f) e1) e2)-      | f == Thy.arrMapPlusB = EApp (EApp (EVar Thy.bagCup) (go e1)) (go e2)-    -- arr_const_s true == arr_map_le_b e1 e2 -> Bag_sub e1 e2-    go (PAtom Eq (EApp (EVar f1) PTrue) (EApp (EApp (EVar f2) e1) e2))-      | f1 == Thy.arrConstS && f2 == Thy.arrMapLeB = EApp (EApp (EVar Thy.bagSub) (go e1)) (go e2)-    -- arr_map_ite_b (arr_map_gt_b e1 e2) e1 e2 -> Bag_max e1 e2-    go (EApp (EApp (EApp (EVar f1) (EApp (EApp (EVar f2) e1a) e2a)) e1b) e2b)-      | f1 == Thy.arrMapIteB && f2 == Thy.arrMapGtB && e1a == e1b && e2a == e2b-      = EApp (EApp (EVar Thy.bagMax) (go e1a)) (go e2a)-    -- arr_map_ite_b (arr_map_le_b e1 e2) e1 e2 -> Bag_min e1 e2-    go (EApp (EApp (EApp (EVar f1) (EApp (EApp (EVar f2) e1a) e2a)) e1b) e2b)-      | f1 == Thy.arrMapIteB && f2 == Thy.arrMapLeB && e1a == e1b && e2a == e2b-      = EApp (EApp (EVar Thy.bagMin) (go e1a)) (go e2a)-    -- Recursive cases-    go (EApp e1 e2)       = EApp   (go e1) (go e2)-    go (ENeg e)           = ENeg   (go e)-    go (EBin b e1 e2)     = EBin b (go e1) (go e2)-    go (ELet x e1 e2)     = ELet x (go e1) (go e2)-    go (EIte e1 e2 e3)    = EIte   (go e1) (go e2) (go e3)-    go (ECst e t)         = ECst   (go e) t-    go (ELam b e)         = ELam b (go e)-    go (ETApp e t)        = ETApp  (go e) t-    go (ETAbs e t)        = ETAbs  (go e) t-    go (PAnd es)          = PAnd   (go <$> es)-    go (POr es)           = POr    (go <$> es)-    go (PNot e)           = PNot   (go e)-    go (PImp e1 e2)       = PImp   (go e1) (go e2)-    go (PIff e1 e2)       = PIff   (go e1) (go e2)-    go (PAtom r e1 e2)    = PAtom r (go e1) (go e2)-    go (PAll   bs e)      = PAll bs (go e)-    go (PExist bs e)      = PExist bs (go e)-    go (ECoerc a t e)     = ECoerc a t (go e)-    go (PKVar k tsu su)       = PKVar k tsu (mapKVarSubst go su)-    go e                  = e---elabSorts :: Cfg.ElabFlags -> Expr -> Expr-elabSorts ef (EApp e1 e2)      = EApp (elabSorts ef e1) (elabSorts ef e2)-elabSorts ef (ENeg e)          = ENeg (elabSorts ef e)-elabSorts ef (EBin b e1 e2)    = EBin b (elabSorts ef e1) (elabSorts ef e2)-elabSorts ef (ELet x e1 e2)    = ELet x (elabSorts ef e1) (elabSorts ef e2)-elabSorts ef (EIte e1 e2 e3)   = EIte (elabSorts ef e1) (elabSorts ef e2) (elabSorts ef e3)-elabSorts ef (ECst e s)        = ECst (elabSorts ef e) (coerceSort ef s)-elabSorts ef (ELam b e)        = ELam b (elabSorts ef e)-elabSorts ef (ETApp e s)       = ETApp (elabSorts ef e) (coerceSort ef s)-elabSorts ef (ETAbs e t)       = ETAbs (elabSorts ef e) t-elabSorts ef (PAnd es)         = PAnd (elabSorts ef <$> es)-elabSorts ef (POr es)          = POr (elabSorts ef <$> es)-elabSorts ef (PNot e)          = PNot (elabSorts ef e)-elabSorts ef (PImp e1 e2)      = PImp (elabSorts ef e1) (elabSorts ef e2)-elabSorts ef (PIff e1 e2)      = PIff (elabSorts ef e1) (elabSorts ef e2)-elabSorts ef (PAtom r e1 e2)   = PAtom r (elabSorts ef e1) (elabSorts ef e2)-elabSorts ef (PAll   bs e)     = PAll bs (elabSorts ef e)-elabSorts ef (PExist bs e)     = PExist bs (elabSorts ef e)-elabSorts ef (ECoerc s1 s2 e)  = ECoerc (coerceSort ef s1) (coerceSort ef s2) (elabSorts ef e)-elabSorts ef (PKVar k tsu su)      = PKVar k tsu (mapKVarSubst (elabSorts ef) su)-elabSorts _ e                 = e------------------------------------------------------------------------------------- | 'elabExpr' adds "casts" to decorate polymorphic instantiation sites.----------------------------------------------------------------------------------elabExpr :: HasCallStack => ElabParam -> Maybe Sort -> Expr -> Expr-elabExpr ep t e = case elabExprE ep t e of-  Left ex  -> die ex-  Right e' -> F.notracepp ("elabExp " ++ showpp e) e'--validateSort :: Env -> Sort -> Maybe Sort -> CheckM ()--- validateSort f t (Just t') = void (unifys f (tracepp ("validateSort" ++ show (t, t')) Nothing) [t] [t'])-validateSort f t (Just t') = void (unifys f Nothing [t] [t'])-validateSort _ _ Nothing   = return ()--elabExprE :: ElabParam -> Maybe Sort -> Expr -> Either Error Expr-elabExprE (ElabParam ef msg env) t e =-  case runCM0 (srcSpan msg) (Just ef) $ do-    (!e', eSort) <- elab (env, envLookup) e-    validateSort envLookup eSort t-    finalThetaRef <- asks chTVSubst-    finalTheta <- liftIO $ readIORef finalThetaRef-    return (applyExpr finalTheta e') of-    Left (ChError f') ->-      let e' = f' ()-      in Left $ err (srcSpan e') (d (val e'))-    Right elab_e -> Right elab_e-  where-    sEnv = seSort env-    envLookup = (`lookupSEnvWithDistance` sEnv)-    d m  = vcat [ "elaborate" <+> text (val msg) <+> "failed on:"-                , nest 4 (pprint e)-                , "with error"-                , nest 4 (text m)-                , "in environment"-                , nest 4 (pprint $ subEnv sEnv e)-                ]-------------------------------------------------------------------------------------- | 'elabApply' replaces all direct function calls indirect calls via `apply`----------------------------------------------------------------------------------elabApply :: SymEnv -> Expr -> Expr-elabApply env = go-  where-    go e                  = case splitArgs e of-                             (e', []) -> step e'-                             (f , es) -> defuncEApp env (go f) (first go <$> es)-    step (PAnd [])        = PTrue-    step (POr [])         = PFalse-    step (ENeg e)         = ENeg (go  e)-    step (EBin o e1 e2)   = EBin o (go e1) (go e2)-    step (ELet x e1 e2)   = ELet x (go e1) (go e2)-    step (EIte e1 e2 e3)  = EIte (go e1) (go e2) (go e3)-    step (ECst e t)       = ECst (go e) t-    step (PAnd ps)        = PAnd (go <$> ps)-    step (POr ps)         = POr  (go <$> ps)-    step (PNot p)         = PNot (go p)-    step (PImp p q)       = PImp (go p) (go q)-    step (PIff p q)       = PIff (go p) (go q)-    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 (ELam b e)       = ELam b       (go e)-    step (ECoerc a t e)   = ECoerc a t   (go e)-    step (PKVar k tsu su)     = PKVar k tsu (mapKVarSubst go su)-    step e@ESym{}         = e-    step e@ECon{}         = e-    step e@EVar{}         = e-    -- ETApp, ETAbs, PAll, PExist-    step e                = error $ "TODO elabApply: " ++ showpp e------------------------------------------------------------------------------------- | Sort Inference ----------------------------------------------------------------------------------------------------------------------------------------------sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort-sortExpr l γ e = case runCM0 l Nothing (checkExpr f e) of-    Left (ChError f') -> die $ err l (d (val (f' ())))-    Right s -> s-  where-    f   = (`lookupSEnvWithDistance` γ)-    d m = vcat [ "sortExpr failed on expression:"-               , nest 4 (pprint e)-               , "with error:"-               , nest 4 (text m)-               , "in environment"-               , nest 4 (pprint γ)-               ]--checkSortExpr :: SrcSpan -> SEnv Sort -> Expr -> Maybe Sort-checkSortExpr sp γ e = case runCM0 sp Nothing (checkExpr f e) of-    Left _   -> Nothing-    Right s  -> Just s-  where-    f x  = case lookupSEnv x γ of-            Just z  -> Found z-            Nothing -> Alts []--subEnv :: (Subable e, Variable e ~ Symbol) => SEnv a -> e -> SEnv a-subEnv g e = intersectWithSEnv const g g'-  where-    g' = fromListSEnv $ (, ()) <$> syms e-------------------------------------------------------------------------------------- | Checking Refinements ------------------------------------------------------------------------------------------------------------------------------------------- | Types used throughout checker-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-                   , chElabF :: Cfg.ElabFlags-                   , chTVSubst :: IORef (Maybe TVSubst)-                   }--type Env      = Symbol -> SESearch Sort-type ElabEnv  = (SymEnv, Env)------------------------------------------------------------------------------------mkSearchEnv :: SEnv a -> Symbol -> SESearch a----------------------------------------------------------------------------------mkSearchEnv env x = lookupSEnvWithDistance x env--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)-    )---- XXX: Why start at 42?-{-# NOINLINE varCounterRef #-}-varCounterRef :: IORef Int-varCounterRef = unsafePerformIO $ newIORef 42---- XXX: Since 'varCounterRef' was made global, this--- function is not referentially transparent.--- Each evaluation of the function starts with a different--- value of counter.-runCM0 :: SrcSpan -> Maybe Cfg.ElabFlags -> CheckM a -> Either ChError a-runCM0 sp mef act = unsafePerformIO $ do-  ref <- newIORef Nothing-  try (runReaderT act (ChS varCounterRef sp (fromMaybe (Cfg.ElabFlags False False) mef) ref))--fresh :: CheckM Int-fresh = do-  rn <- asks chCount-  liftIO $ atomicModifyIORef' rn $ \n -> (n+1, n)------------------------------------------------------------------------------------- | Checking Refinements ----------------------------------------------------------------------------------------------------------------------------------------checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc-checkSortedReft env xs sr = applyNonNull Nothing oops unknowns-  where-    oops                  = Just . (text "Unknown symbols:" <+>) . toFix-    unknowns              = [ x | x <- syms sr, x `notElem` v : xs, not (x `memberSEnv` env)]-    Reft (v,_)            = sr_reft sr--checkSortedReftFull :: Checkable a => SrcSpan -> SEnv SortedReft -> a -> ElabM (Maybe Doc)-checkSortedReftFull sp γ t =-  do ef <- ask-     pure $ case runCM0 sp (Just ef) (check γ' t) of-              Left (ChError f)  -> Just (text (val (f ())))-              Right _ -> Nothing-  where-    γ' = sr_sort <$> γ--checkSortFull :: Checkable a => SrcSpan -> SEnv SortedReft -> Sort -> a -> ElabM (Maybe Doc)-checkSortFull sp γ s t =-  do ef <- ask-     pure $ case runCM0 sp (Just ef) (checkSort γ' s t) of-              Left (ChError f)  -> Just (text (val (f ())))-              Right _ -> Nothing-  where-      γ' = sr_sort <$> γ--checkSorted :: Checkable a => SrcSpan -> SEnv Sort -> a -> ElabM (Maybe Doc)-checkSorted sp γ t =-  do ef <- ask-     pure $ case runCM0 sp (Just ef) (check γ t) of-              Left (ChError f) -> Just (text (val (f ())))-              Right _  -> Nothing--pruneUnsortedReft :: SEnv Sort -> Templates -> SortedReft -> SortedReft-pruneUnsortedReft _ t r-  | isEmptyTemplates t-  = r-pruneUnsortedReft γ t (RR s (Reft (v, p)))-  | isAnyTemplates t-  -- this is the old code that checks everything-  = RR s (Reft (v, tx filterAny p))-  | otherwise-  = RR s (Reft (v, tx (filter filterWithTemplate) p))-  where-    filterAny = mapMaybe (checkPred' f)-    filterWithTemplate e =  not (matchesTemplates t e) || isJust (checkPred' f e)-    tx f' = pAnd . f' . conjuncts-    f    = (`lookupSEnvWithDistance` γ')-    γ'   = insertSEnv v s γ-    -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t--checkPred' :: Env -> Expr -> Maybe Expr-checkPred' f p = res -- traceFix ("checkPred: p = " ++ showFix p) $ res-  where-    res        = case runCM0 dummySpan Nothing (checkPred f p) of-                   Left _err -> notracepp ("Removing" ++ showpp p) Nothing-                   Right _   -> Just p--class Checkable a where-  check     :: SEnv Sort -> a -> CheckM ()-  checkSort :: SEnv Sort -> Sort -> a -> CheckM ()--  checkSort γ _ = check γ--instance Checkable Expr where-  check γ e =-    do ef <- asks chElabF-       _ <- checkExpr (`lookupSEnvWithDistance` coerceSortEnv ef γ) e-       pure ()--  checkSort γ s e =-    do ef <- asks chElabF-       _ <- checkExpr (`lookupSEnvWithDistance` coerceSortEnv ef γ)-                      (ECst e (if Cfg.elabSetBag ef then coerceSetBagToArray s' else s'))-       pure ()-   where-      s' = coerceMapToArray s--instance Checkable SortedReft where-  check γ (RR s (Reft (v, ra))) = check γ' ra-   where-     γ' = insertSEnv v s γ------------------------------------------------------------------------------------- | Checking Expressions ----------------------------------------------------------------------------------------------------------------------------------------checkExpr                   :: Env -> Expr -> CheckM Sort-checkExpr _ (ESym _)        = return strSort-checkExpr _ (ECon (I _))    = return FInt-checkExpr _ (ECon (R _))    = return FReal-checkExpr _ (ECon (L _ s))  = return s-checkExpr f (EVar x)        = checkSym f x-checkExpr f (ENeg e)        = checkNeg f e-checkExpr f (EBin o e1 e2)  = checkOp f e1 o e2-checkExpr f (ELet x e1 e2)  = checkLet f x e1 e2-checkExpr f (EIte p e1 e2)  = checkIte f p e1 e2-checkExpr f (ECst e t)      = checkCst f t e-checkExpr f (EApp g e)      = checkApp f Nothing g e-checkExpr f (PNot p)        = checkPred f p >> return boolSort-checkExpr f (PImp p p')     = mapM_ (checkPred f) [p, p'] >> return boolSort-checkExpr f (PIff p p')     = mapM_ (checkPred f) [p, p'] >> return boolSort-checkExpr f (PAnd ps)       = mapM_ (checkPred f) ps >> return boolSort-checkExpr f (POr ps)        = mapM_ (checkPred f) ps >> return boolSort-checkExpr f (PAtom r e e')  = checkRel f r e e' >> return boolSort-checkExpr _ PKVar{}         = return boolSort--checkExpr f (PAll  bs e )   = checkExpr (addEnv f bs) e-checkExpr f (PExist bs e)   = checkExpr (addEnv f bs) e-checkExpr f (ELam (x,t) e)  = FFunc t <$> checkExpr (addEnv f [(x,t)]) e-checkExpr f (ECoerc s t e)  = checkExpr f (ECst e s) >> return t-checkExpr _ (ETApp _ _)     = error "SortCheck.checkExpr: TODO: implement ETApp"-checkExpr _ (ETAbs _ _)     = error "SortCheck.checkExpr: TODO: implement ETAbs"--addEnv :: Eq a => (a -> SESearch b) -> [(a, b)] -> a -> SESearch b-addEnv f bs x-  = case L.lookup x bs of-      Just s  -> Found s-      Nothing -> f x------------------------------------------------------------------------------------- | 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-  (!e1', !s1) <- elab f e1-  (!e2', !s2) <- elab f e2-  !s <- checkOpTy g e s1 s2-  let !result = EBin o (eCst e1' s1) (eCst e2' s2)-  return (result, s)--elab !f (ECst (EApp !e1 !e2) t) = do-   ee <- elabAppAs f t e1 e2-   return (eCst ee t, t)--elab !f (EApp !e1 !e2) = do-  (!e1', !s1, !e2', !s2, !s) <- elabEApp f e1 e2-  let !e = eAppC s (eCst e1' s1) (eCst e2' s2)-  return (e, s)--elab !_ e@(ESym _) =-  return (e, strSort)--elab !_ e@(ECon (I _)) =-  return (e, FInt)--elab !_ e@(ECon (R _)) =-  return (e, FReal)--elab !_ e@(ECon (L _ !s)) =-  return (e, s)---- TODO: the guard below is because some LH tests generate PKVar with ill-sorted substitutions.--- However, a cleaner solution could be to modify `Sanitize.restrictKVarDomain` to simply--- those ill-sorted substitutions right up at the outset.-elab !f e@(PKVar k tsu su) = do-  expKvars <- asks (elabExplicitKvars . chElabF)-  if expKvars-    then do-      xargs' <- forM (HashMap.toList $ fromKVarSubst su) $ \(x, arg) -> do-        (arg', _) <- elab f arg-        return (x, arg')-      return (PKVar k tsu (toKVarSubst (HashMap.fromList xargs')), boolSort)-    else-      return (e, boolSort)--elab (!_, !f) e@(EVar !x) = do-  !cs <- checkSym f x-  return (e, cs)--elab !f (ENeg !e) = do-  (!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' (eCst e1' s) (eCst e2' s), t)--elab f@(!_,!g) (EIte !p !e1 !e2) = do-  !t <- getIte g e1 e2-  (!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' (eCst e1' s) (eCst e2' s), s)--elab f (ELet !x !e1 !e2) = do-  (!e1', !t1) <- elab f e1-  (!e2', !t2) <- elab (elabAddEnv f [(x, t1)]) e2-  return (ELet x e1' e2', t2)--elab !f (ECst !e !t) = do-  (!e', !_) <- elab f e-  return (eCst e' t, t)--elab !f (PNot !p) = do-  (!e', !_) <- elab f p-  return (PNot e', boolSort)--elab !f (PImp !p1 !p2) = do-  (!p1', !_) <- elab f p1-  (!p2', !_) <- elab f p2-  return (PImp p1' p2', boolSort)--elab !f (PIff !p1 !p2) = do-  (!p1', !_) <- elab f p1-  (!p2', !_) <- elab f p2-  return (PIff p1' p2', boolSort)--elab !f (PAnd !ps) = do-  !ps' <- mapM (elab f) ps-  return (PAnd (fst <$> ps'), boolSort)--elab !f (POr !ps) = do-  !ps' <- mapM (elab f) ps-  return (POr (fst <$> ps'), boolSort)--elab f@(!_,!g) e@(PAtom !eq !e1 !e2) | eq == Eq || eq == Ne = do-  !t1        <- checkExpr g e1-  !t2        <- checkExpr g e2-  (!t1',!t2') <- unite g e t1 t2 `withError` errElabExpr e-  !e1'       <- elabAs f t1' e1-  !e2'       <- elabAs f t2' e2-  !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-  (!e1', !_) <- elab f e1-  (!e2', !_) <- elab f e2-  return (PAtom r e1' e2', boolSort)--elab f@(!env,!_) (PAtom !r !e1 !e2) = do-  !e1' <- uncurry (toInt env) <$> elab f e1-  !e2' <- uncurry (toInt env) <$> elab f e2-  return (PAtom r e1' e2', boolSort)--elab !f (PExist !bs !e) = do-  (!e', !s) <- elab (elabAddEnv f bs) e-  !ef <- asks chElabF-  let !bs' = elaborate (ElabParam ef "PExist Args" mempty) bs-  return (PExist bs' e', s)--elab !f (PAll !bs !e) = do-  (!e', !s) <- elab (elabAddEnv f bs) e-  !ef <- asks chElabF-  let !bs' = elaborate (ElabParam ef "PAll Args" mempty) bs-  return (PAll bs' e', s)--elab !f (ELam (!x,!t) !e) = do-  (!e', !s) <- elab (elabAddEnv f [(x, t)]) e-  !ef <- asks chElabF-  let !t' = elaborate (ElabParam ef "ELam Arg" mempty) t-  return (ELam (x, t') (eCst e' s), FFunc t s)--elab !f (ECoerc !s !t !e) = do-  (!e', !_) <- elab f e-  return (ECoerc s t e', t)--elab !_ (ETApp _ _) =-  error "SortCheck.elab: TODO: implement ETApp"-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) (ECst (EVar x) _) t-  | Found s <- g x-  , isUndef s-  , not (isNum sym t) = (`eCst` t) <$> elabAppAs f t (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)--elabAs :: ElabEnv -> Sort -> Expr -> CheckM Expr-elabAs f t e = notracepp _msg <$> go e-  where-    _msg  = "elabAs: t = " ++ showpp t ++ "; e = " ++ showpp e-    go (EApp e1 e2)    = elabAppAs f t e1 e2-    go e'              = fst <$> elab f (eCst e' t)---- DUPLICATION with `checkApp'`-elabAppAs :: ElabEnv -> Sort -> Expr -> Expr -> CheckM Expr-elabAppAs env@(_, f) t g e = do-  gT       <- checkExpr f g-  eT       <- checkExpr f e-  (iT, oT, isu) <- checkFunSort gT-  let ge    = Just (EApp g e)-  su       <- unifyMany f ge isu [oT, iT] [t, eT]-  let tg    = apply su gT-  g'       <- elabAs env tg g-  let te    = apply su eT-  e'       <- elabAs env te e-  pure     $ EApp (eCst g' tg) (eCst e' te)--elabEApp  :: ElabEnv -> Expr -> Expr -> CheckM (Expr, Sort, Expr, Sort, Sort)-elabEApp f@(_, g) e1 e2 = do-  (e1', s1)     <- {- notracepp ("elabEApp: e1 = " ++ show e1) <$> -} elab f e1-  (e2', s2)     <- {- notracepp ("elabEApp: e2 = " ++ show e2) <$> -} elab f e2-  (e1'', e2'', s1', s2', s) <- elabAppSort g e1' e2' s1 s2-  return           (e1'', s1', e2'', s2', s)--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-  composeTVSubst (Just su)-  composeTVSubst (Just su')-  return (e1 , e2, apply su' s1, apply su' s2, apply su' sOut)-------------------------------------------------------------------------------------- | defuncEApp monomorphizes function applications.----------------------------------------------------------------------------------defuncEApp :: SymEnv -> Expr -> [(Expr, Sort)] -> Expr-defuncEApp _   e [] = e-defuncEApp env e es = eCst (L.foldl' makeApplication e' es') (snd $ last es)-  where-    (e', es')       = takeArgs (seTheory env) e es--takeArgs :: SEnv TheorySymbol -> Expr -> [(Expr, a)] -> (Expr, [(Expr, a)])-takeArgs env e es =-  case Thy.isSmt2App env e of-    Just n  -> let (es1, es2) = splitAt n es-               in (eApps e (fst <$> es1), es2)-    Nothing -> (e, es)---- 'e1' is the function, 'e2' is the argument, 's' is the OUTPUT TYPE-makeApplication :: Expr -> (Expr, Sort) -> Expr-makeApplication e1 (e2, s) =-  ECst (EApp (EApp f e1) e2) s-  where-    f  = {- notracepp ("makeApplication: " ++ showpp (e2, t2)) $ -} applyAt t2 s-    t2 = exprSort "makeAppl" e2--applyAt :: Sort -> Sort -> Expr-applyAt s t = ECst (EVar applyName) (FFunc s t)---- JUST make "toInt" call "makeApplication" also, so they are wrapped in apply--- MAY CAUSE CRASH (apply-on-apply) so rig `isSmt2App` to treat `apply` as SPECIAL.---- TODO: proper toInt-toInt :: SymEnv -> Expr -> Sort -> Expr-toInt env e s-  | isSmtInt  = e-  | otherwise = ECst (EApp f (ECst e s)) FInt-  where-    isSmtInt  = isNum env s-    f         = toIntAt s--isNum :: SymEnv -> Sort -> Bool-isNum env s = case sortSmtSort False (seData env) s of-  SInt    -> True-  SString -> True-  SReal   -> True-  _       -> False--isFractional :: SymEnv -> Sort -> Bool-isFractional env (FObj l)-  = lookupSEnv l (seSort env) `elem` [Just FFrac, Just realSort]-isFractional _ s = isReal s----toIntAt :: Sort -> Expr-toIntAt s = ECst (EVar toIntName) (FFunc s FInt)--unElab :: Expr -> Expr-unElab = Vis.stripCasts . unApply--unElabSortedReft :: SortedReft -> SortedReft-unElabSortedReft sr = sr { sr_reft = mapPredReft unElab (sr_reft sr) }--unApplySortedReft :: SortedReft -> SortedReft-unApplySortedReft sr = sr { sr_reft = mapPredReft unApply (sr_reft sr) }--unApply :: Expr -> Expr-unApply = Vis.mapExprOnExpr go-  where-    go (ECst (EApp (EApp f e1) e2) _)-      | Just _ <- unApplyAt f = EApp e1 e2-    go (ELam (x,s) e)         = ELam (x, Vis.mapSort go' s) e-    go (PExist bs e)          = PExist (map (second (Vis.mapSort go')) bs) e-    go e                      = e--    go' (FApp (FApp fs t1) t2) | fs == funcSort-          = FFunc t1 t2-    go' t = t---unApplyAt :: Expr -> Maybe Sort-unApplyAt (ECst (EVar f) t@FFunc{})-  | f == applyName = Just t-unApplyAt _        = Nothing---splitArgs :: Expr -> (Expr, [(Expr, Sort)])-splitArgs = go []-  where-    go acc (ECst (EApp e1 e) s) = go ((e, s) : acc) e1-    go _   e@EApp{}             = errorstar $ "UNEXPECTED: splitArgs: EApp without output type: " ++ showpp e-    go acc e                    = (e, acc)-----------------------------------------------------------------------------------{- | [NOTE:apply-monomorphization]--     Because SMTLIB does not support higher-order functions,-     all _non-theory_ function applications--        EApp e1 e2--     are represented, in SMTLIB, as--        (EApp (EApp apply e1) e2)--     where 'apply' is 'ECst (EVar "apply") t' and-           't'     is 'FFunc a b'-           'a','b' are the sorts of 'e2' and 'e1 e2' respectively.--     Note that *all polymorphism* goes through this machinery.--     Just before sending to the SMT solver, we use the cast 't'-     to generate a special 'apply_at_t' symbol.--     To let us do the above, we populate 'SymEnv' with the _set_-     of all sorts at which 'apply' is used, computed by 'applySorts'.- -}--{- | [NOTE:coerce-apply] -- related to [NOTE:apply-monomorphism]--Haskell's GADTs cause a peculiar problem illustrated below:--```haskell-data Field a where-  FInt  :: Field Int-  FBool :: Field Bool--{-@ reflect proj @-}-proj :: Field a -> a -> a-proj fld x = case fld of-               FInt  -> 1 + x-               FBool -> not b-```--**The Problem**--The problem is you cannot encode the body of `proj` as a well-sorted refinement:--```haskell-    if is$FInt fld-        then (1 + (coerce (a ~ Int)  x))-        else (not (coerce (a ~ Bool) x))-```--The catch is that `x` is being used BOTH as `Int` and as `Bool`-which is not supported in SMTLIB.--**Approach: Uninterpreted Functions**--We encode `coerce` as an explicit **uninterpreted function**:--```haskell-    if is$FInt fld-        then (1 + (coerce@(a -> int)  x))-        else (not (coerce@(a -> bool) x))-```--where we define, extra constants in the style of `apply`--```haskell-   constant coerce@(a -> int ) :: a -> int-   constant coerce@(a -> bool) :: a -> int-```--However, it would not let us verify:---```haskell-{-@ reflect unwrap @-}-unwrap :: Field a -> a -> a-unwrap fld x = proj fld x--{-@ test :: _ -> TT @-}-test =  unwrap FInt  4    == 5-     && unwrap FBool True == False-```--because we'd get--```haskell-  unwrap FInt 4 :: { if is$FInt FInt then (1 + coerce_int_int 4) else ...  }-```--and the UIF nature of `coerce_int_int` renders the VC invalid.--**Solution: Eliminate Trivial Coercions**--HOWEVER, the solution here, may simply be to use UIFs when the-coercion is non-trivial (e.g. `a ~ int`) but to eschew them when-they are trivial. That is we would encode:--| Expr                   | SMTLIB             |-|:-----------------------|:-------------------|-| `coerce (a ~ int) x`   | `coerce_a_int x`   |-| `coerce (int ~ int) x` | `x`                |--which, I imagine is what happens _somewhere_ inside GHC too?---}-----------------------------------------------------------------------------------applySorts :: Vis.Foldable t => t -> [Sort]----------------------------------------------------------------------------------applySorts = {- tracepp "applySorts" . -} (defs ++) . Vis.fold vis () []-  where-    defs   = [FFunc t1 t2 | t1 <- basicSorts, t2 <- basicSorts]-    vis    = (Vis.defaultFolder :: Vis.Folder [KVar] t) { Vis.accExpr = go }-    go _ (EApp (ECst (EVar f) t) _)   -- get types needed for [NOTE:apply-monomorphism]-           | f == applyName-           = [t]-    go _ (ECoerc t1 t2 _)             -- get types needed for [NOTE:coerce-apply]-           = [FFunc t1 t2]-    go _ _ = []------------------------------------------------------------------------------------- | Expressions sort  -------------------------------------------------------------------------------------------------------------------------------------------exprSort :: String -> Expr -> Sort-exprSort msg e = fromMaybe (panic err') (exprSortMaybe e)-  where-    err'        = printf "exprSort [%s] on unexpected expression %s" msg (show e)--exprSortMaybe :: Expr -> Maybe Sort-exprSortMaybe = go-  where-    go (ECst _ s) = Just s-    go (ELam (_, sx) e) = FFunc sx <$> go e-    go (EApp e ex)-      | Just (FFunc sx s) <- genSort <$> go e-      = maybe s (`apply` s) . (`unifySorts` sx) <$> go ex-    go _ = Nothing--genSort :: Sort -> Sort-genSort (FAbs _ t) = genSort t-genSort t          = t--unite :: Env -> Expr -> Sort -> Sort -> CheckM (Sort, Sort)-unite f e t1 t2 = do-  su <- unifys f (Just e) [t1] [t2]-  return (apply su t1, apply su t2)--throwErrorAt :: String -> CheckM a-throwErrorAt ~err' = do -- Lazy pattern needed because we use LANGUAGE Strict in this module-                        -- 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-  Found s -> refreshNegativeTyVars s >>= instantiate-  Alts xs -> throwErrorAt (errUnboundAlts x xs)---- Negative type variables are implictly universally quantified type variables-refreshNegativeTyVars :: Sort -> CheckM Sort-refreshNegativeTyVars s = do-    let negativeSorts = negSort s-    freshVars <- mapM pair $ S.toList negativeSorts-    pure $ foldr (uncurry subst) s freshVars-  where-    pair i = do-      f <- fresh-      pure (i, FVar f)--    negSort (FVar i) | i < 0 = S.singleton i-    negSort (FAbs _ s')      = negSort s'-    negSort (FFunc s1 s2)    = negSort s1 `S.union` negSort s2-    negSort (FApp s1 s2)     = negSort s1 `S.union` negSort s2-    negSort _                = S.empty---- | Helper for checking let expressions-checkLet :: Env -> Symbol -> Expr -> Expr -> CheckM Sort-checkLet f x e1 e2 = do-  t <- checkExpr f e1-  checkExpr (addEnv f [(x, t)]) e2---- | Helper for checking if-then-else expressions-checkIte :: Env -> Expr -> Expr -> Expr -> CheckM Sort-checkIte f p e1 e2 = do-  checkPred f p-  t1 <- checkExpr f e1-  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-  where-    e' = Just (EIte p e1 e2)---- | Helper for checking cast expressions-checkCst :: Env -> Sort -> Expr -> CheckM Sort-checkCst f t (EApp g e)-  = checkApp f (Just t) g e-checkCst f t e-  = do t' <- checkExpr f e-       su <- unifys f (Just e) [t] [t'] `withError` errCast e t' t-       pure (apply su t)--checkApp :: Env -> Maybe Sort -> Expr -> Expr -> CheckM Sort-checkApp f to g es-  = snd <$> checkApp' f to g es--checkExprAs :: Env -> Sort -> Expr -> CheckM Sort-checkExprAs f t (EApp g e)-  = checkApp f (Just t) g e-checkExprAs f t e-  = do t' <- checkExpr f e-       θ  <- unifys f (Just e) [t'] [t]-       pure $ apply θ t---- | Helper for checking uninterpreted function applications--- | Checking function application should be curried, e.g.--- | fromJust :: Maybe a -> a, f :: Maybe (b -> b), x: c |- fromJust f x---   RJ: The above comment makes no sense to me :(---- DUPLICATION with 'elabAppAs'-checkApp' :: Env -> Maybe Sort -> Expr -> Expr -> CheckM (TVSubst, Sort)-checkApp' f to g e = do-  gt       <- checkExpr f g-  et       <- checkExpr f e-  (it, ot, isu) <- checkFunSort gt-  let ge    = Just (EApp g e)-  su        <- unifyMany f ge isu [it] [et]-  let t     = apply su ot-  case to of-    Nothing    -> return (su, t)-    Just t'    -> do θ' <- unifyMany f ge su [t] [t']-                     let ti = apply θ' et-                     _ <- checkExprAs f ti e-                     return (θ', apply θ' t)----- | Helper for checking binary (numeric) operations-checkNeg :: Env -> Expr -> CheckM Sort-checkNeg f e = do-  t <- checkExpr f e-  checkNumeric f t >> return t--checkOp :: Env -> Expr -> Bop -> Expr -> CheckM Sort-checkOp f e1 o e2-  = do t1 <- checkExpr f e1-       t2 <- checkExpr f e2-       checkOpTy f (EBin o e1 e2) t1 t2---checkOpTy :: Env -> Expr -> Sort -> Sort -> CheckM Sort-checkOpTy _ _ FInt FInt-  = return FInt--checkOpTy _ _ FReal FReal-  = return FReal--- Coercing int to real is somewhat suspicious, but z3 seems--- to be ok with it-checkOpTy _ _ FInt  FReal-  = return FReal-checkOpTy _ _ FReal FInt-  = return FReal--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')--checkFractional :: Env -> Sort -> CheckM ()-checkFractional f s@(FObj l)-  = do t <- checkSym f l-       unless (t `elem` [FFrac, realSort]) (throwErrorAt $ errNonFractional s)-checkFractional _ s-  = unless (isReal s) $ throwErrorAt (errNonFractional s)--checkNumeric :: Env -> Sort -> CheckM ()-checkNumeric f s@(FObj l)-  = do t <- checkSym f l-       unless (t `elem` [FNum, FFrac, intSort, FInt]) (throwErrorAt $ errNonNumeric s)-checkNumeric _ s-  = unless (isNumeric s) (throwErrorAt $ errNonNumeric s)--checkEqConstr :: Env -> Maybe Expr -> TVSubst -> Symbol -> Sort -> CheckM TVSubst-checkEqConstr _ _  θ a (FObj b)-  | a == b-  = return θ-checkEqConstr f e θ a t =-  case f a of-    Found tA -> unify1 f e θ tA t-    _        -> throwErrorAt $ errUnifyMsg (Just "ceq2") e (FObj a) t------------------------------------------------------------------------------------- | Checking Predicates -----------------------------------------------------------------------------------------------------------------------------------------checkPred :: Env -> Expr -> CheckM ()-checkPred f e = checkExpr f e >>= checkBoolSort e--checkBoolSort :: Expr -> Sort -> CheckM ()-checkBoolSort e s-  | s == boolSort = return ()-  | otherwise     = throwErrorAt (errBoolSort e s)---- | Checking Relations-checkRel :: HasCallStack => Env -> Brel -> Expr -> Expr -> CheckM ()-checkRel f Eq e1 e2 = do-  t1 <- checkExpr f e1-  t2 <- checkExpr f e2-  su <- unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2-  _  <- checkExprAs f (apply su t1) e1-  _  <- checkExprAs f (apply su t2) e2-  checkRelTy f e Eq t1 t2-  where-    e = PAtom Eq e1 e2--checkRel f r  e1 e2 = do-  t1 <- checkExpr f e1-  t2 <- checkExpr f e2-  checkRelTy f (PAtom r e1 e2) r t1 t2---checkRelTy :: Env -> Expr -> Brel -> Sort -> Sort -> CheckM ()-checkRelTy _ e Ueq s1 s2     = checkURel e s1 s2-checkRelTy _ e Une s1 s2     = checkURel e s1 s2-checkRelTy f _ _ s1@(FObj l) s2@(FObj l') | l /= l'-                             = (checkNumeric f s1 >> checkNumeric f s2) `withError` errNonNumerics l l'-checkRelTy _ _ _ FReal FReal = return ()-checkRelTy _ _ _ FInt  FReal = return ()-checkRelTy _ _ _ FReal FInt  = return ()-checkRelTy f _ _ FInt  s2    = checkNumeric    f s2 `withError` errNonNumeric s2-checkRelTy f _ _ s1    FInt  = checkNumeric    f s1 `withError` errNonNumeric s1-checkRelTy f _ _ FReal s2    = checkFractional f s2 `withError` errNonFractional s2-checkRelTy f _ _ s1    FReal = checkFractional f s1 `withError` errNonFractional s1-checkRelTy f e Eq t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2)-checkRelTy f e Ne t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` errRel e t1 t2)-checkRelTy _ e _  t1 t2      = unless (t1 == t2) (throwErrorAt $ errRel e t1 t2)---- | @a ~~ b@ is translated to @(= a b)@ when producing SMTLIB.--- But this is only valid if @a@ and @b@ have the same sort in SMTLIB.--- It turns out that most types are represented with sort Int, so comparing--- values of different types is not rejected in general by SMT solvers.------ There are at least two exceptions though. The first of them is the type--- Bool, which is represented with the sort Bool. Therefore, @a ~~ b@ is fine--- if both arguments have Bool sort, or if neither of them has.------ The other exception is functions, which have a function sort in SMTLIB.--- But at the moment no @~~@ equalities are produced with function sorts, so--- that case isn't considered in this function.----checkURel :: Expr -> Sort -> Sort -> CheckM ()-checkURel e s1 s2 = unless (b1 == b2) (throwErrorAt $ errRel e s1 s2)-  where-    b1            = s1 == boolSort-    b2            = s2 == boolSort-------------------------------------------------------------------------------------- | Sort Unification----------------------------------------------------------------------------------{-# SCC unify #-}-unify :: Env -> Maybe Expr -> Sort -> Sort -> Maybe TVSubst----------------------------------------------------------------------------------unify f e t1 t2-  = case runCM0 dummySpan Nothing (unify1 f e emptySubst t1 t2) of-      Left _   -> Nothing-      Right su -> Just su-----------------------------------------------------------------------------------unifyTo1 :: Env -> [Sort] -> Maybe Sort----------------------------------------------------------------------------------unifyTo1 f ts-  = case runCM0 dummySpan Nothing (unifyTo1M f ts) of-      Left _  -> Nothing-      Right t -> Just t------------------------------------------------------------------------------------unifyTo1M :: Env -> [Sort] -> CheckM Sort----------------------------------------------------------------------------------unifyTo1M _ []     = panic "unifyTo1: empty list"-unifyTo1M f (t0:ts) = snd <$> foldM step (emptySubst, t0) ts-  where-    step :: (TVSubst, Sort) -> Sort -> CheckM (TVSubst, Sort)-    step (su, t) t' = do-      su' <- unify1 f Nothing su t t'-      return (su', apply su' t)------------------------------------------------------------------------------------unifySorts :: Sort -> Sort -> Maybe TVSubst----------------------------------------------------------------------------------unifySorts = unifyFast False emptyEnv-  where-    emptyEnv x = die $ err dummySpan $ "SortCheck: lookup in Empty Env: " <> pprint x-------------------------------------------------------------------------------------- | Fast Unification; `unifyFast True` is just equality----------------------------------------------------------------------------------unifyFast :: Bool -> Env -> Sort -> Sort -> Maybe TVSubst----------------------------------------------------------------------------------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 :: HasCallStack => Env -> Maybe Expr -> [Sort] -> [Sort] -> CheckM TVSubst----------------------------------------------------------------------------------unifys f e = unifyMany f e emptySubst--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')--unify1 :: Env -> Maybe Expr -> TVSubst -> Sort -> Sort -> CheckM TVSubst-unify1 f e !θ (FVar !i) !t-  = unifyVar f e θ i t-unify1 f e !θ !t (FVar !i)-  = unifyVar f e θ i t-unify1 f e !θ (FApp !t1 !t2) (FApp !t1' !t2')-  = unifyMany f e θ [t1, t2] [t1', t2']-unify1 _ _ !θ (FTC !l1) (FTC !l2)-  | isListTC l1 && isListTC l2-  = return θ-unify1 f e !θ t1@(FAbs _ _) !t2 = do-  !t1' <- instantiate t1-  unifyMany f e θ [t1'] [t2]-unify1 f e !θ !t1 t2@(FAbs _ _) = do-  !t2' <- instantiate t2-  unifyMany f e θ [t1] [t2']-unify1 _ _ !θ !s1 !s2-  | isString s1, isString s2-  = return θ-unify1 _ _ !θ FInt  FReal = return θ--unify1 _ _ !θ FReal FInt  = return θ--unify1 f e !θ !t FInt = do-  checkNumeric f t `withError` errUnify e t FInt-  return θ--unify1 f e !θ FInt !t = do-  checkNumeric f t `withError` errUnify e FInt t-  return θ--unify1 f e !θ !t FReal = do-  checkFractional f t `withError` errUnify e t FReal-  return θ--unify1 f e !θ FReal !t = do-  checkFractional f t `withError` errUnify e FReal t-  return θ--unify1 f e !θ (FFunc !t1 !t2) (FFunc !t1' !t2') =-  unifyMany f e θ [t1, t2] [t1', t2']--unify1 f e θ (FObj a) !t =-  checkEqConstr f e θ a t--unify1 f e θ !t (FObj a) =-  checkEqConstr f e θ a t--unify1 _ e θ !t1 !t2-  | t1 == t2-  = return θ-  | otherwise-  = throwErrorAt (errUnify e t1 t2)--subst :: Int -> Sort -> Sort -> Sort-subst !j !tj t@(FVar !i)-  | i == j                  = tj-  | otherwise               = t--subst !j !tj (FApp !t1 !t2)  = FApp t1' t2'-  where-    !t1'                    = subst j tj t1-    !t2'                    = subst j tj t2---- subst _ _  !(FTC l)         = FTC l-subst !j !tj (FFunc !t1 !t2) = FFunc t1' t2'-  where-    !t1'                    = subst j tj $! t1-    !t2'                    = subst j tj $! t2--subst !j !tj (FAbs !i !t)-  | i == j                  = FAbs i t-  | otherwise               = FAbs i t'-  where-    !t'                     = subst j tj t--subst _  _   !s             = s-----------------------------------------------------------------------------------instantiate :: Sort -> CheckM Sort----------------------------------------------------------------------------------instantiate !t = go t-  where-    go (FAbs !i !t') = do-      !t''   <- instantiate t'-      !v     <- fresh-      return $ subst i (FVar v) t''-    go !t' =-      return t'--unifyVar :: Env -> Maybe Expr -> TVSubst -> Int -> Sort -> CheckM TVSubst-unifyVar _ _ θ !i t@(FVar !j)-  = case lookupVar i θ of-      Just !t'      -> if t == t' then return θ else return (updateVar j t' θ)-      Nothing       -> return (updateVar i t θ)--unifyVar f e θ !i !t-  = case lookupVar i θ of-      Just (FVar !j) -> return $ updateVar i t $ updateVar j t θ-      Just !t'       -> if t == t' then return θ else unify1 f e θ t t'-      Nothing        -> return (updateVar i t θ)-------------------------------------------------------------------------------------- | Update global subst to be applied to expressions-----------------------------------------------------------------------------------updateTVSubst :: TVSubst -> CheckM ()-updateTVSubst theta = do-  refTheta <- asks chTVSubst-  liftIO $ atomicModifyIORef' refTheta $ const (Just theta, ())---- local (\s -> s {chTVSubst = theta}) (return ())--mergeTVSubst :: TVSubst -> Maybe TVSubst -> TVSubst-mergeTVSubst (Th m1) Nothing = Th m1-mergeTVSubst (Th m1) (Just (Th m2)) = Th m1 <> Th m2--composeTVSubst :: Maybe TVSubst -> CheckM ()-composeTVSubst Nothing = return ()-composeTVSubst (Just theta1) = do-  refTheta <- asks chTVSubst-  theta <- liftIO $ readIORef refTheta-  updateTVSubst (mergeTVSubst theta1 theta)------------------------------------------------------------------------------------- | Applying a Type Substitution --------------------------------------------------------------------------------------------------------------------------------apply :: TVSubst -> Sort -> Sort----------------------------------------------------------------------------------apply !θ          = Vis.mapSort f-  where-    f t@(FVar !i) = fromMaybe t (lookupVar i θ)-    f !t          = t--applyExpr :: Maybe TVSubst -> Expr -> Expr-applyExpr Nothing e  = e-applyExpr (Just θ) e = Vis.mapExprOnExpr f e-  where-    f (ECst !e' !s) = ECst e' (apply θ s)-    f !e'          = e'------------------------------------------------------------------------------------- | Deconstruct a function-sort ---------------------------------------------------------------------------------------------------------------------------------checkFunSort :: Sort -> CheckM (Sort, Sort, TVSubst)-checkFunSort (FAbs _ t)    = checkFunSort t-checkFunSort (FFunc t1 t2) = return (t1, t2, emptySubst)-checkFunSort (FVar i)      = do j <- fresh-                                k <- fresh-                                return (FVar j, FVar k, updateVar i (FFunc (FVar j) (FVar k)) emptySubst)-checkFunSort t             = throwErrorAt (errNonFunction 1 t)------------------------------------------------------------------------------------- | API for manipulating Sort Substitutions ----------------------------------------------------------------------------------------------------------------------newtype TVSubst = Th (M.IntMap Sort) deriving (Show)--instance Semigroup TVSubst where-  (Th s1) <> (Th s2) = Th (s1 <> s2)--instance Monoid TVSubst where-  mempty  = Th mempty-  mappend = (<>)--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)--emptySubst :: TVSubst-emptySubst = Th M.empty------------------------------------------------------------------------------------- | Error messages -----------------------------------------------------------------------------------------------------------------------------------------------errElabExpr   :: Expr -> String-errElabExpr e = printf "Elaborate fails on %s" (showpp e)--errUnifyMsg :: Maybe String -> Maybe Expr -> Sort -> Sort -> String-errUnifyMsg msgMb eo t1 t2-  = printf "Cannot unify %s with %s %s %s"-      (showpp t1) {- (show t1) -} (showpp t2) {-(show t2)-} (errUnifyExpr eo) msgStr-    where-      msgStr = case msgMb of { Nothing -> ""; Just s -> "<< " ++ s ++ " >>"}--errUnify :: Maybe Expr -> Sort -> Sort -> String-errUnify = errUnifyMsg Nothing--errUnifyExpr :: Maybe Expr -> String-errUnifyExpr Nothing  = ""-errUnifyExpr (Just e) = "in expression: " ++ showpp e--errUnifyMany :: [Sort] -> [Sort] -> String-errUnifyMany ts ts'  = printf "Cannot unify types with different cardinalities %s and %s"-                         (showpp ts) (showpp ts')--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-errOp e t t'-  | t == t'          = printf "Operands have non-numeric types %s in %s"-                         (showpp t) (showpp e)-  | otherwise        = printf "Operands have different types %s and %s in %s"-                         (showpp t) (showpp t') (showpp e)--errIte :: Expr -> Expr -> Sort -> Sort -> String-errIte e1 e2 t1 t2   = printf "Mismatched branches in Ite: then %s : %s, else %s : %s"-                         (showpp e1) (showpp t1) (showpp e2) (showpp t2)--errCast :: Expr -> Sort -> Sort -> String-errCast e t' t       = printf "Cannot cast %s of sort %s to incompatible sort %s"-                         (showpp e) (showpp t') (showpp t)--errUnboundAlts :: Symbol -> [Symbol] -> String-errUnboundAlts x xs  = printf "Unbound symbol %s --- perhaps you meant: %s ?"-                         (showpp x) (L.intercalate ", " (showpp <$> xs))--errNonFunction :: Int -> Sort -> String-errNonFunction i t   = printf "The sort %s is not a function with at least %s arguments\n" (showpp t) (showpp i)--errNonNumeric :: Sort -> String-errNonNumeric  l     = printf "The sort %s is not numeric" (showpp l)--errNonNumerics :: Symbol -> Symbol -> String-errNonNumerics l l'  = printf "FObj sort %s and %s are different and not numeric" (showpp l) (showpp l')--errNonFractional :: Sort -> String-errNonFractional  l  = printf "The sort %s is not fractional" (showpp l)--errBoolSort :: Expr -> Sort -> String-errBoolSort     e s  = printf "Expressions %s should have bool sort, but has %s" (showpp e) (showpp s)--globalEnv :: Cfg.Config -> F.GInfo c a -> SEnv Sort-globalEnv cfg finfo = F.gLits finfo <> dataEnv-  where-    dataEnv = F.tsSort <$> theoryEnv cfg finfo--theoryEnv :: Cfg.Config -> F.GInfo c a -> F.SEnv F.TheorySymbol-theoryEnv cfg si-  =  Thy.theorySymbols (Cfg.solver cfg)-  <> Thy.theorySymbols (F.defns si)-  <> Thy.theorySymbols (F.ddecls si)+{-# LANGUAGE StrictData            #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections         #-}+{-# 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.++module Language.Fixpoint.SortCheck  (+  -- * Sort Substitutions+    TVSubst+  , Env+  , mkSearchEnv++  -- * Checking Well-Formedness+  , checkSorted+  , checkSortedReft+  , checkSortedReftFull+  , checkSortFull+  , pruneUnsortedReft++  -- * Sort inference+  , sortExpr+  , checkSortExpr+  , exprSort+  , exprSort_maybe++  -- * Unify+  , unifyFast+  , unifySorts+  , unifyTo1+  , unifys++  -- * Apply Substitution+  , apply+  , defuncEApp++  -- * Exported Sorts+  , boolSort+  , strSort++  -- * Sort-Directed Transformations+  , Elaborate (..)+  , applySorts+  , unElab, unElabSortedReft, unApplyAt+  , toInt++  -- * Predicates on Sorts+  , isFirstOrder+  , isMono++  , runCM0+  ) where++--  import           Control.DeepSeq+import           Control.Exception (Exception, catch, try, throwIO)+import           Control.Monad+import           Control.Monad.Except      -- (MonadError(..))+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)+import           Data.Semigroup            (Semigroup (..))+#endif+++import           Language.Fixpoint.Types.PrettyPrint+import           Language.Fixpoint.Misc+import           Language.Fixpoint.Types hiding   (subst)+import qualified Language.Fixpoint.Types.Visitor  as Vis+import qualified Language.Fixpoint.Smt.Theories   as Thy+import           Text.PrettyPrint.HughesPJ.Compat+import           Text.Printf++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 -------------------------------------------------------+--------------------------------------------------------------------------------+isMono :: Sort -> Bool+--------------------------------------------------------------------------------+isMono             = null . Vis.foldSort fv []+  where+    fv vs (FVar i) = i : vs+    fv vs _        = vs+++--------------------------------------------------------------------------------+-- | Elaborate: make polymorphic instantiation explicit via casts,+--   make applications monomorphic for SMTLIB. This deals with+--   polymorphism by `elaborate`-ing all refinements except for+--   KVars. THIS IS NOW MANDATORY as sort-variables can be+--   instantiated to `int` and `bool`.+--------------------------------------------------------------------------------+class Elaborate a where+  elaborate :: Located String -> SymEnv -> a -> a+++instance (Loc a) => Elaborate (SInfo a) where+  elaborate x senv si = si+    { cm      = elaborate x senv <$> cm      si+    , bs      = elaborate x senv  $  bs      si+    , asserts = elaborate x senv <$> asserts si+    }++instance (Elaborate e) => (Elaborate (Triggered e)) where+  elaborate x env t = fmap (elaborate x env) t++instance (Elaborate a) => (Elaborate (Maybe a)) where+  elaborate x env t = fmap (elaborate x env) t++instance Elaborate Sort where+  elaborate _ _ = go+   where+      go s | isString s = strSort+      go (FAbs i s)    = FAbs i   (go s)+      go (FFunc s1 s2) = funSort (go s1) (go s2)+      go (FApp s1 s2)  = FApp    (go s1) (go s2)+      go s             = s+      funSort :: Sort -> Sort -> Sort+      funSort = FApp . FApp funcSort++instance Elaborate AxiomEnv where+  elaborate msg env ae = ae+    { aenvEqs   = elaborate msg env (aenvEqs ae) +    -- MISSING SORTS OOPS, aenvSimpl = elaborate msg env (aenvSimpl ae) +    }++instance Elaborate Rewrite where +  elaborate msg env rw = rw { smBody = skipElabExpr msg env' (smBody rw) } +    where +      env' = insertsSymEnv env undefined++instance Elaborate Equation where +  elaborate msg env eq = eq { eqBody = skipElabExpr msg env' (eqBody eq) } +    where+      env' = insertsSymEnv env (eqArgs eq) ++instance Elaborate Expr where+  elaborate msg env = elabNumeric . elabApply env . elabExpr msg env+++skipElabExpr :: Located String -> SymEnv -> Expr -> Expr +skipElabExpr msg env e = case elabExprE msg env e of +  Left _   -> e +  Right e' ->  elabNumeric . elabApply env $ e'++instance Elaborate (Symbol, Sort) where+  elaborate msg env (x, s) = (x, elaborate msg env s)++instance Elaborate a => Elaborate [a]  where+  elaborate msg env xs = elaborate msg env <$> xs++elabNumeric :: Expr -> Expr+elabNumeric = Vis.mapExprOnExpr go+  where+    go (ETimes e1 e2)+      | exprSort "txn1" e1 == FReal+      , exprSort "txn2" e2 == FReal+      = ERTimes e1 e2+    go (EDiv   e1 e2)+      | exprSort ("txn3: " ++ showpp e1) e1 == FReal+      , exprSort "txn4" e2 == FReal+      = ERDiv   e1 e2+    go e+      = e++instance Elaborate SortedReft where+  elaborate x env (RR s (Reft (v, e))) = RR s (Reft (v, e'))+    where+      e'   = elaborate x env' e+      env' = insertSymEnv v s env++instance Elaborate BindEnv where+  elaborate z env = mapBindEnv (\i (x, sr) -> (x, elaborate (z' i x sr) env sr))+    where+      z' i  x sr  = z { val = (val z) ++ msg i x sr }+      msg i x sr  = unwords [" elabBE",  show i, show x, show sr]++instance (Loc a) => Elaborate (SimpC a) where+  elaborate msg env c = c {_crhs = elaborate msg' env (_crhs c) }+    where msg'        = atLoc c (val msg)+--------------------------------------------------------------------------------+-- | 'elabExpr' adds "casts" to decorate polymorphic instantiation sites.+--------------------------------------------------------------------------------+elabExpr :: Located String -> SymEnv -> Expr -> Expr+elabExpr msg env e = case elabExprE msg env e of +  Left ex  -> die ex +  Right e' -> F.notracepp ("elabExp " ++ showpp e) e' ++elabExprE :: Located String -> SymEnv -> Expr -> Either Error Expr+elabExprE msg env e = +  case runCM0 (srcSpan msg) (elab (env, f) e) of+    Left (ChError f) ->+      let e = f ()+       in Left $ err (srcSpan e) (d (val e))+    Right s  -> Right (fst s)+  where+    sEnv = seSort env+    f    = (`lookupSEnvWithDistance` sEnv)+    d m  = vcat [ "elaborate" <+> text (val msg) <+> "failed on:"+                , nest 4 (pprint e)+                , "with error"+                , nest 4 (text m)+                , "in environment"+                , nest 4 (pprint $ subEnv sEnv e)+                ]++--------------------------------------------------------------------------------+-- | 'elabApply' replaces all direct function calls indirect calls via `apply`+--------------------------------------------------------------------------------+elabApply :: SymEnv -> Expr -> Expr+elabApply env = go+  where+    go e                  = case splitArgs e of+                             (e', []) -> step e'+                             (f , es) -> defuncEApp env (go f) (mapFst go <$> es)+    step (PAnd [])        = PTrue+    step (POr [])         = PFalse+    step (ENeg e)         = ENeg (go  e)+    step (EBin o e1 e2)   = EBin o (go e1) (go e2)+    step (EIte e1 e2 e3)  = EIte (go e1) (go e2) (go e3)+    step (ECst e t)       = ECst (go e) t+    step (PAnd ps)        = PAnd (go <$> ps)+    step (POr ps)         = POr  (go <$> ps)+    step (PNot p)         = PNot (go p)+    step (PImp p q)       = PImp (go p) (go q)+    step (PIff p q)       = PIff (go p) (go q)+    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 (ELam b e)       = ELam b       (go e)+    step (ECoerc a t e)   = ECoerc a t   (go e)+    step (PGrad k su i e) = PGrad k su i (go e)+    step e@(PKVar {})     = e+    step e@(ESym {})      = e+    step e@(ECon {})      = e+    step e@(EVar {})      = e+    -- ETApp, ETAbs, PAll, PExist+    step e                = error $ "TODO elabApply: " ++ showpp e++--------------------------------------------------------------------------------+-- | Sort Inference ------------------------------------------------------------+--------------------------------------------------------------------------------+sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort+sortExpr l γ e = case runCM0 l (checkExpr f e) of+    Left (ChError f) -> die $ err l (d (val (f ())))+    Right s -> s+  where+    f   = (`lookupSEnvWithDistance` γ)+    d m = vcat [ "sortExpr failed on expression:"+               , nest 4 (pprint e)+               , "with error:"+               , nest 4 (text m)+               , "in environment"+               , nest 4 (pprint γ)+               ]++checkSortExpr :: SrcSpan -> SEnv Sort -> Expr -> Maybe Sort+checkSortExpr sp γ e = case runCM0 sp (checkExpr f e) of+    Left _   -> Nothing+    Right s  -> Just s+  where+    f x  = case lookupSEnv x γ of+            Just z  -> Found z+            Nothing -> Alts []++subEnv :: (Subable e) => SEnv a -> e -> SEnv a+subEnv g e = intersectWithSEnv (\t _ -> t) g g'+  where+    g' = fromListSEnv $ (, ()) <$> syms e+++--------------------------------------------------------------------------------+-- | Checking Refinements ------------------------------------------------------+--------------------------------------------------------------------------------++-- | Types used throughout checker+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)+++--------------------------------------------------------------------------------+mkSearchEnv :: SEnv a -> Symbol -> SESearch a +--------------------------------------------------------------------------------+mkSearchEnv env x = lookupSEnvWithDistance x env  ++-- withError :: CheckM a -> ChError -> CheckM a+-- act `withError` e' = act `catchError` (\e -> throwError (atLoc e (val e ++ "\n  because\n" ++ val e')))++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 = unsafePerformIO $ do+  rn <- newIORef 42+  try (runReaderT act (ChS rn sp))++fresh :: CheckM Int+fresh = do+  rn <- asks chCount+  liftIO $ do+    n <- readIORef rn+    writeIORef rn (n + 1)+    return n++--------------------------------------------------------------------------------+-- | Checking Refinements ------------------------------------------------------+--------------------------------------------------------------------------------+checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc+checkSortedReft env xs sr = applyNonNull Nothing oops unknowns+  where+    oops                  = Just . (text "Unknown symbols:" <+>) . toFix+    unknowns              = [ x | x <- syms sr, x `notElem` v : xs, not (x `memberSEnv` env)]+    Reft (v,_)            = sr_reft sr++checkSortedReftFull :: Checkable a => SrcSpan -> SEnv SortedReft -> a -> Maybe Doc+checkSortedReftFull sp γ t = +  case runCM0 sp (check γ' t) of+    Left (ChError f)  -> Just (text (val (f ())))+    Right _ -> Nothing+  where+    γ' = sr_sort <$> γ++checkSortFull :: Checkable a => SrcSpan -> SEnv SortedReft -> Sort -> a -> Maybe Doc+checkSortFull sp γ s t = +  case runCM0 sp (checkSort γ' s t) of+    Left (ChError f)  -> Just (text (val (f ())))+    Right _ -> Nothing+  where+      γ' = sr_sort <$> γ++checkSorted :: Checkable a => SrcSpan -> SEnv Sort -> a -> Maybe Doc+checkSorted sp γ t = +  case runCM0 sp (check γ t) of+    Left (ChError f)  -> Just (text (val (f ())))+    Right _  -> Nothing++pruneUnsortedReft :: SEnv Sort -> Templates -> SortedReft -> SortedReft+pruneUnsortedReft _ t r +  | isEmptyTemplates t +  = r +pruneUnsortedReft γ t (RR s (Reft (v, p)))+  | isAnyTemplates t +  -- this is the old code that checks everything +  = RR s (Reft (v, tx filterAny p))+  | otherwise+  = RR s (Reft (v, tx (filter filterWithTemplate) p))+  where+    filterAny = mapMaybe (checkPred' f)+    filterWithTemplate e =  not (matchesTemplates t e) || isJust (checkPred' f e)+    tx f = pAnd . f . conjuncts+    f    = (`lookupSEnvWithDistance` γ')+    γ'   = insertSEnv v s γ+    -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t++checkPred' :: Env -> Expr -> Maybe Expr+checkPred' f p = res -- traceFix ("checkPred: p = " ++ showFix p) $ res+  where+    res        = case runCM0 dummySpan (checkPred f p) of+                   Left _err -> notracepp ("Removing" ++ showpp p) Nothing+                   Right _   -> Just p++class Checkable a where+  check     :: SEnv Sort -> a -> CheckM ()+  checkSort :: SEnv Sort -> Sort -> a -> CheckM ()++  checkSort γ _ = check γ++instance Checkable Expr where+  check γ e = void $ checkExpr f e+   where f =  (`lookupSEnvWithDistance` γ)++  checkSort γ s e = void $ checkExpr f (ECst e s)+    where+      f           =  (`lookupSEnvWithDistance` γ)++instance Checkable SortedReft where+  check γ (RR s (Reft (v, ra))) = check γ' ra+   where+     γ' = insertSEnv v s γ++--------------------------------------------------------------------------------+-- | Checking Expressions ------------------------------------------------------+--------------------------------------------------------------------------------+checkExpr                  :: Env -> Expr -> CheckM Sort+checkExpr _ (ESym _)       = return strSort+checkExpr _ (ECon (I _))   = return FInt+checkExpr _ (ECon (R _))   = return FReal+checkExpr _ (ECon (L _ s)) = return s+checkExpr f (EVar x)       = checkSym f x+checkExpr f (ENeg e)       = checkNeg f e+checkExpr f (EBin o e1 e2) = checkOp f e1 o e2+checkExpr f (EIte p e1 e2) = checkIte f p e1 e2+checkExpr f (ECst e t)     = checkCst f t e+checkExpr f (EApp g e)     = checkApp f Nothing g e+checkExpr f (PNot p)       = checkPred f p >> return boolSort+checkExpr f (PImp p p')    = mapM_ (checkPred f) [p, p'] >> return boolSort+checkExpr f (PIff p p')    = mapM_ (checkPred f) [p, p'] >> return boolSort+checkExpr f (PAnd ps)      = mapM_ (checkPred f) ps >> return boolSort+checkExpr f (POr ps)       = mapM_ (checkPred f) ps >> return boolSort+checkExpr f (PAtom r e e') = checkRel f r e e' >> return boolSort+checkExpr _ (PKVar {})     = return boolSort+checkExpr f (PGrad _ _ _ e)  = checkPred f e >> return boolSort++checkExpr f (PAll  bs e )  = checkExpr (addEnv f bs) e+checkExpr f (PExist bs e)  = checkExpr (addEnv f bs) e+checkExpr f (ELam (x,t) e) = FFunc t <$> checkExpr (addEnv f [(x,t)]) e+checkExpr f (ECoerc s t e) = checkExpr f (ECst e s) >> return t +checkExpr _ (ETApp _ _)    = error "SortCheck.checkExpr: TODO: implement ETApp"+checkExpr _ (ETAbs _ _)    = error "SortCheck.checkExpr: TODO: implement ETAbs"++addEnv :: Eq a => (a -> SESearch b) -> [(a, b)] -> a -> SESearch b+addEnv f bs x+  = case L.lookup x bs of+      Just s  -> Found s+      Nothing -> f x++--------------------------------------------------------------------------------+-- | 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+  (e1', s1) <- elab f e1+  (e2', s2) <- elab f e2+  s <- checkOpTy g e s1 s2+  return (EBin o (ECst e1' s1) (ECst e2' s2), s)++elab f (EApp e1@(EApp _ _) e2) = do+  (e1', _, e2', s2, s) <- notracepp "ELAB-EAPP" <$> elabEApp f e1 e2+  let e = eAppC s e1' (ECst e2' s2)+  let θ = unifyExpr (snd f) e+  return (applyExpr θ e, maybe s (`apply` s) θ)++elab f (EApp e1 e2) = do+  (e1', s1, e2', s2, s) <- elabEApp f e1 e2+  let e = eAppC s (ECst e1' s1) (ECst e2' s2)+  let θ = unifyExpr (snd f) e+  return (applyExpr θ e, maybe s (`apply` s) θ)++elab _ e@(ESym _) =+  return (e, strSort)++elab _ e@(ECon (I _)) =+  return (e, FInt)++elab _ e@(ECon (R _)) =+  return (e, FReal)++elab _ e@(ECon (L _ s)) =+  return (e, s)++elab _ e@(PKVar _ _) =+  return (e, boolSort)++elab f (PGrad k su i e) =+  ((, boolSort) . PGrad k su i . fst) <$> elab f e++elab (_, f) e@(EVar x) =+  (e,) <$> checkSym f x++elab f (ENeg e) = do+  (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 (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)++elab f (ECst e t) = do+  (e', _) <- elab f e+  return (ECst e' t, t)++elab f (PNot p) = do+  (e', _) <- elab f p+  return (PNot e', boolSort)++elab f (PImp p1 p2) = do+  (p1', _) <- elab f p1+  (p2', _) <- elab f p2+  return (PImp p1' p2', boolSort)++elab f (PIff p1 p2) = do+  (p1', _) <- elab f p1+  (p2', _) <- elab f p2+  return (PIff p1' p2', boolSort)++elab f (PAnd ps) = do+  ps' <- mapM (elab f) ps+  return (PAnd (fst <$> ps'), boolSort)++elab f (POr ps) = do+  ps' <- mapM (elab f) ps+  return (POr (fst <$> ps'), boolSort)++elab f@(_,g) e@(PAtom eq e1 e2) | eq == Eq || eq == Ne = do+  t1        <- checkExpr g e1+  t2        <- checkExpr g e2+  (t1',t2') <- unite g e  t1 t2 `withError` (errElabExpr e)+  e1'       <- elabAs f t1' e1+  e2'       <- elabAs f t2' e2+  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+  (e1', _) <- elab f e1+  (e2', _) <- elab f e2+  return (PAtom r e1' e2', boolSort)++elab f@(env,_) (PAtom r e1 e2) = do+  e1' <- uncurry (toInt env) <$> elab f e1+  e2' <- uncurry (toInt env) <$> elab f e2+  return (PAtom r e1' e2', boolSort)++elab f (PExist bs e) = do+  (e', s) <- elab (elabAddEnv f bs) e+  let bs' = elaborate "PExist Args" mempty bs+  return (PExist bs' e', s)++elab f (PAll bs e) = do+  (e', s) <- elab (elabAddEnv f bs) e+  let bs' = elaborate "PAll Args" mempty bs+  return (PAll bs' e', s)++elab f (ELam (x,t) e) = do+  (e', s) <- elab (elabAddEnv f [(x, t)]) e+  let t' = elaborate "ELam Arg" mempty t+  return (ELam (x, t') (ECst e' s), FFunc t s)++elab f (ECoerc s t e) = do+  (e', _) <- elab f e+  return     (ECoerc s t e', t)++elab _ (ETApp _ _) =+  error "SortCheck.elab: TODO: implement ETApp"+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)++cast :: Expr -> Sort -> Expr+cast (ECst e _) t = ECst e t+cast e          t = ECst e t++elabAs :: ElabEnv -> Sort -> Expr -> CheckM Expr+elabAs f t e = notracepp _msg <$>  go e+  where+    _msg  = "elabAs: t = " ++ showpp t ++ " e = " ++ showpp e+    go (EApp e1 e2)   = elabAppAs f t e1 e2+    go e              = fst    <$> elab f e++-- DUPLICATION with `checkApp'`+elabAppAs :: ElabEnv -> Sort -> Expr -> Expr -> CheckM Expr+elabAppAs env@(_, f) t g e = do+  gT       <- checkExpr f g+  eT       <- checkExpr f e+  (iT, oT, isu) <- checkFunSort gT+  let ge    = Just (EApp g e)+  su       <- unifyMany f ge isu [oT, iT] [t, eT]+  let tg    = apply su gT+  g'       <- elabAs env tg g+  let te    = apply su eT+  e'       <- elabAs env te e+  return    $ EApp (ECst g' tg) (ECst e' te)++elabEApp  :: ElabEnv -> Expr -> Expr -> CheckM (Expr, Sort, Expr, Sort, Sort)+elabEApp f@(_, g) e1 e2 = do+  (e1', s1)     <- notracepp ("elabEApp1: e1 = " ++ showpp e1) <$> elab f e1+  (e2', s2)     <- elab f e2+  (e1'', e2'', s1', s2', s) <- elabAppSort g e1' e2' s1 s2+  return           (e1'', s1', e2'', s2', s)++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           $ (applyExpr (Just su') e1, applyExpr (Just su') e2, apply su' s1, apply su' s2, apply su' sOut)+++--------------------------------------------------------------------------------+-- | defuncEApp monomorphizes function applications.+--------------------------------------------------------------------------------+defuncEApp :: SymEnv -> Expr -> [(Expr, Sort)] -> Expr+defuncEApp env e es = L.foldl' makeApplication e' es'+  where+    (e', es')       = takeArgs (seTheory env) e es++takeArgs :: SEnv TheorySymbol -> Expr -> [(Expr, a)] -> (Expr, [(Expr, a)])+takeArgs env e es =+  case Thy.isSmt2App env (Vis.stripCasts e) of+    Just n  -> let (es1, es2) = splitAt n es+               in (eApps e (fst <$> es1), es2)+    Nothing -> (e, es)++-- 'e1' is the function, 'e2' is the argument, 's' is the OUTPUT TYPE+makeApplication :: Expr -> (Expr, Sort) -> Expr+makeApplication e1 (e2, s) = ECst (EApp (EApp f e1) e2) s+  where+    f                      = {- notracepp ("makeApplication: " ++ showpp (e2, t2)) $ -} applyAt t2 s+    t2                     = exprSort "makeAppl" e2++applyAt :: Sort -> Sort -> Expr+applyAt s t = ECst (EVar applyName) (FFunc s t)++-- JUST make "toInt" call "makeApplication" also, so they are wrapped in apply+-- MAY CAUSE CRASH (apply-on-apply) so rig `isSmt2App` to treat `apply` as SPECIAL.++-- TODO: proper toInt+toInt :: SymEnv -> Expr -> Sort -> Expr+toInt env e s+  | isSmtInt  = e+  | otherwise = ECst (EApp f (ECst e s)) FInt+  where+    isSmtInt  = isInt env s+    f         = toIntAt s++isInt :: SymEnv -> Sort -> Bool+isInt env s = case sortSmtSort False (seData env) s of+  SInt    -> True+  SString -> True+  SReal   -> True+  _       -> False++toIntAt :: Sort -> Expr+toIntAt s = ECst (EVar toIntName) (FFunc s FInt)++unElab :: Expr -> Expr+unElab = Vis.stripCasts . unApply++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) _)+      | Just _ <- unApplyAt f = EApp e1 e2+    go (ELam (x,s) e)         = ELam (x, Vis.mapSort go' s) e +    go e                      = e++    go' (FApp (FApp fs t1) t2) | fs == funcSort +          = FFunc t1 t2 +    go' t = t +++unApplyAt :: Expr -> Maybe Sort+unApplyAt (ECst (EVar f) t@(FFunc {}))+  | f == applyName = Just t+unApplyAt _        = Nothing+++splitArgs :: Expr -> (Expr, [(Expr, Sort)])+splitArgs = go []+  where+    go acc (ECst (EApp e1 e) s) = go ((e, s) : acc) e1+    go _   e@EApp{}             = errorstar $ "UNEXPECTED: splitArgs: EApp without output type: " ++ showpp e+    go acc e                    = (e, acc)++--------------------------------------------------------------------------------+{- | [NOTE:apply-monomorphization]++     Because SMTLIB does not support higher-order functions,+     all _non-theory_ function applications++        EApp e1 e2++     are represented, in SMTLIB, as++        (Eapp (EApp apply e1) e2)++     where 'apply' is 'ECst (EVar "apply") t' and+           't'     is 'FFunc a b'+           'a','b' are the sorts of 'e2' and 'e1 e2' respectively.++     Note that *all polymorphism* goes through this machinery.++     Just before sending to the SMT solver, we use the cast 't'+     to generate a special 'apply_at_t' symbol.++     To let us do the above, we populate 'SymEnv' with the _set_+     of all sorts at which 'apply' is used, computed by 'applySorts'.+ -}++{- | [NOTE:coerce-apply] -- related to [NOTE:apply-monomorphism]++Haskell's GADTs cause a peculiar problem illustrated below:++```haskell+data Field a where+  FInt  :: Field Int+  FBool :: Field Bool++{-@ reflect proj @-}+proj :: Field a -> a -> a+proj fld x = case fld of+               FInt  -> 1 + x+               FBool -> not b  +```++## The Problem++The problem is you cannot encode the body of `proj` as a well-sorted refinement:+ +```haskell+    if is$FInt fld+        then (1 + (coerce (a ~ Int)  x))+        else (not (coerce (a ~ Bool) x))+```++The catch is that `x` is being used BOTH as `Int` and as `Bool` +which is not supported in SMTLIB.++## Approach: Uninterpreted Functions++We encode `coerce` as an explicit **uninterpreted function**:++```haskell+    if is$FInt fld+        then (1 + (coerce@(a -> int)  x))+        else (not (coerce@(a -> bool) x))+```++where we define, extra constants in the style of `apply` ++```haskell+   constant coerce@(a -> int ) :: a -> int+   constant coerce@(a -> bool) :: a -> int+```++However, it would not let us verify:+++```haskell+{-@ reflect unwrap @-}+unwrap :: Field a -> a -> a+unwrap fld x = proj fld x++{-@ test :: _ -> TT @-}+test =  unwrap FInt  4    == 5+     && unwrap FBool True == False+```++because we'd get++```haskell+  unwrap FInt 4 :: { if is$FInt FInt then (1 + coerce_int_int 4) else ...  }+```++and the UIF nature of `coerce_int_int` renders the VC invalid.++## Solution: Eliminate Trivial Coercions++HOWEVER, the solution here, may simply be to use UIFs when the+coercion is non-trivial (e.g. `a ~ int`) but to eschew them when+they are trivial. That is we would encode:++| Expr                   | SMTLIB             |+|:-----------------------|:-------------------|+| `coerce (a ~ int) x`   | `coerce_a_int x`   |+| `coerce (int ~ int) x` | `x`                |++which, I imagine is what happens _somewhere_ inside GHC too?++-}++--------------------------------------------------------------------------------+applySorts :: Vis.Visitable t => t -> [Sort]+--------------------------------------------------------------------------------+applySorts = {- tracepp "applySorts" . -} (defs ++) . Vis.fold vis () []+  where+    defs   = [FFunc t1 t2 | t1 <- basicSorts, t2 <- basicSorts]+    vis    = (Vis.defaultVisitor :: Vis.Visitor [KVar] t) { Vis.accExpr = go }+    go _ (EApp (ECst (EVar f) t) _)   -- get types needed for [NOTE:apply-monomorphism]+           | f == applyName+           = [t]+    go _ (ECoerc t1 t2 _)             -- get types needed for [NOTE:coerce-apply]+           = [FFunc t1 t2] +    go _ _ = []++--------------------------------------------------------------------------------+-- | Expressions sort  ---------------------------------------------------------+--------------------------------------------------------------------------------+exprSort :: String -> Expr -> Sort+exprSort msg e = fromMaybe (panic err) (exprSort_maybe e)+  where+    err        = printf "exprSort [%s] on unexpected expression %s" msg (show e)++exprSort_maybe :: Expr -> Maybe Sort+exprSort_maybe = go+  where+    go (ECst _ s) = Just s+    go (ELam (_, sx) e) = FFunc sx <$> go e+    go (EApp e ex)+      | Just (FFunc sx s) <- genSort <$> go e+      = maybe s (`apply` s) <$> ((`unifySorts` sx) <$> go ex)+    go _ = Nothing++genSort :: Sort -> Sort+genSort (FAbs _ t) = genSort t+genSort t          = t++unite :: Env -> Expr -> Sort -> Sort -> CheckM (Sort, Sort)+unite f e t1 t2 = do+  su <- unifys f (Just e) [t1] [t2]+  return (apply su t1, apply su t2)++throwErrorAt :: String -> CheckM a +throwErrorAt ~err = do -- Lazy pattern needed because we use LANGUAGE Strict in this module+                       -- 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+  Found s -> instantiate s+  Alts xs -> throwErrorAt (errUnboundAlts x xs)++-- | Helper for checking if-then-else expressions+checkIte :: Env -> Expr -> Expr -> Expr -> CheckM Sort+checkIte f p e1 e2 = do+  checkPred f p+  t1 <- checkExpr f e1+  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)+  where+    e' = Just (EIte p e1 e2)++-- | Helper for checking cast expressions+checkCst :: Env -> Sort -> Expr -> CheckM Sort+checkCst f t (EApp g e)+  = checkApp f (Just t) g e+checkCst f t e+  = do t' <- checkExpr f e+       ((`apply` t) <$> unifys f (Just e) [t] [t']) `withError` (errCast e t' t)++checkApp :: Env -> Maybe Sort -> Expr -> Expr -> CheckM Sort+checkApp f to g es+  = snd <$> checkApp' f to g es++checkExprAs :: Env -> Sort -> Expr -> CheckM Sort+checkExprAs f t (EApp g e)+  = checkApp f (Just t) g e+checkExprAs f t e+  = do t' <- checkExpr f e+       θ  <- unifys f (Just e) [t'] [t]+       return $ apply θ t++-- | Helper for checking uninterpreted function applications+-- | Checking function application should be curried, e.g.+-- | fromJust :: Maybe a -> a, f :: Maybe (b -> b), x: c |- fromJust f x+--   RJ: The above comment makes no sense to me :(++-- DUPLICATION with 'elabAppAs'+checkApp' :: Env -> Maybe Sort -> Expr -> Expr -> CheckM (TVSubst, Sort)+checkApp' f to g e = do+  gt       <- checkExpr f g+  et       <- checkExpr f e+  (it, ot, isu) <- checkFunSort gt+  let ge    = Just (EApp g e)+  su        <- unifyMany f ge isu [it] [et]+  let t     = apply su ot+  case to of+    Nothing    -> return (su, t)+    Just t'    -> do θ' <- unifyMany f ge su [t] [t']+                     let ti = apply θ' et+                     _ <- checkExprAs f ti e+                     return (θ', apply θ' t)+++-- | Helper for checking binary (numeric) operations+checkNeg :: Env -> Expr -> CheckM Sort+checkNeg f e = do+  t <- checkExpr f e+  checkNumeric f t >> return t++checkOp :: Env -> Expr -> Bop -> Expr -> CheckM Sort+checkOp f e1 o e2+  = do t1 <- checkExpr f e1+       t2 <- checkExpr f e2+       checkOpTy f (EBin o e1 e2) t1 t2+++checkOpTy :: Env -> Expr -> Sort -> Sort -> CheckM Sort+checkOpTy _ _ FInt FInt+  = return FInt++checkOpTy _ _ FReal FReal+  = return FReal+-- Coercing int to real is somewhat suspicious, but z3 seems+-- to be ok with it+checkOpTy _ _ FInt  FReal+  = return FReal+checkOpTy _ _ FReal FInt+  = return FReal++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')++checkFractional :: Env -> Sort -> CheckM ()+checkFractional f s@(FObj l)+  = do t <- checkSym f l+       unless (t == FFrac) $ throwErrorAt (errNonFractional s)+checkFractional _ s+  = unless (isReal s) $ throwErrorAt (errNonFractional s)++checkNumeric :: Env -> Sort -> CheckM ()+checkNumeric f s@(FObj l)+  = do t <- checkSym f l+       unless (t `elem` [FNum, FFrac, intSort, FInt]) (throwErrorAt $ errNonNumeric s)+checkNumeric _ s+  = unless (isNumeric s) (throwErrorAt $ errNonNumeric s)++checkEqConstr :: Env -> Maybe Expr -> TVSubst -> Symbol -> Sort -> CheckM TVSubst +checkEqConstr _ _  θ a (FObj b)+  | a == b+  = return θ+checkEqConstr f e θ a t = do+  case f a of+    Found tA -> unify1 f e θ tA t +    _        -> throwErrorAt $ errUnifyMsg (Just "ceq2") e (FObj a) t++--------------------------------------------------------------------------------+-- | Checking Predicates -------------------------------------------------------+--------------------------------------------------------------------------------+checkPred                  :: Env -> Expr -> CheckM ()+checkPred f e = checkExpr f e >>= checkBoolSort e++checkBoolSort :: Expr -> Sort -> CheckM ()+checkBoolSort e s+  | s == boolSort = return ()+  | otherwise     = throwErrorAt (errBoolSort e s)++-- | Checking Relations+checkRel :: HasCallStack => Env -> Brel -> Expr -> Expr -> CheckM ()+checkRel f Eq e1 e2 = do+  t1 <- checkExpr f e1+  t2 <- checkExpr f e2+  su <- (unifys f (Just e) [t1] [t2]) `withError` (errRel e t1 t2)+  _  <- checkExprAs f (apply su t1) e1+  _  <- checkExprAs f (apply su t2) e2+  checkRelTy f e Eq t1 t2+  where+    e = PAtom Eq e1 e2++checkRel f r  e1 e2 = do+  t1 <- checkExpr f e1+  t2 <- checkExpr f e2+  checkRelTy f (PAtom r e1 e2) r t1 t2+++checkRelTy :: Env -> Expr -> Brel -> Sort -> Sort -> CheckM ()+checkRelTy _ e Ueq s1 s2     = checkURel e s1 s2+checkRelTy _ e Une s1 s2     = checkURel e s1 s2 +checkRelTy f _ _ s1@(FObj l) s2@(FObj l') | l /= l'+                             = (checkNumeric f s1 >> checkNumeric f s2) `withError` (errNonNumerics l l')+checkRelTy _ _ _ FReal FReal = return ()+checkRelTy _ _ _ FInt  FReal = return ()+checkRelTy _ _ _ FReal FInt  = return ()+checkRelTy f _ _ FInt  s2    = checkNumeric    f s2 `withError` (errNonNumeric s2)+checkRelTy f _ _ s1    FInt  = checkNumeric    f s1 `withError` (errNonNumeric s1)+checkRelTy f _ _ FReal s2    = checkFractional f s2 `withError` (errNonFractional s2)+checkRelTy f _ _ s1    FReal = checkFractional f s1 `withError` (errNonFractional s1)+checkRelTy f e Eq t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` (errRel e t1 t2))+checkRelTy f e Ne t1 t2      = void (unifys f (Just e) [t1] [t2] `withError` (errRel e t1 t2))+checkRelTy _ e _  t1 t2      = unless (t1 == t2) (throwErrorAt $ errRel e t1 t2)++checkURel :: Expr -> Sort -> Sort -> CheckM ()+checkURel e s1 s2 = unless (b1 == b2) (throwErrorAt $ errRel e s1 s2)+  where +    b1            = s1 == boolSort+    b2            = s2 == boolSort++--------------------------------------------------------------------------------+-- | Sort Unification on Expressions+--------------------------------------------------------------------------------++{-# SCC unifyExpr #-}+unifyExpr :: Env -> Expr -> Maybe TVSubst+unifyExpr f (EApp e1 e2) = Just $ mconcat $ catMaybes [θ1, θ2, θ]+  where+   θ1 = unifyExpr f e1+   θ2 = unifyExpr f e2+   θ  = unifyExprApp f e1 e2+unifyExpr f (ECst e _)+  = unifyExpr f e+unifyExpr _ _+  = Nothing++unifyExprApp :: Env -> Expr -> Expr -> Maybe TVSubst+unifyExprApp f e1 e2 = do+  t1 <- getArg $ exprSort_maybe e1+  t2 <- exprSort_maybe e2+  unify f (Just $ EApp e1 e2) t1 t2+  where+    getArg (Just (FFunc t1 _)) = Just t1+    getArg _                   = Nothing+++--------------------------------------------------------------------------------+-- | Sort Unification+--------------------------------------------------------------------------------+{-# SCC unify #-}+unify :: Env -> Maybe Expr -> Sort -> Sort -> Maybe TVSubst+--------------------------------------------------------------------------------+unify f e t1 t2+  = case runCM0 dummySpan (unify1 f e emptySubst t1 t2) of+      Left _   -> Nothing+      Right su -> Just su++--------------------------------------------------------------------------------+unifyTo1 :: Env -> [Sort] -> Maybe Sort+--------------------------------------------------------------------------------+unifyTo1 f ts  +  = case runCM0 dummySpan (unifyTo1M f ts) of+      Left _  -> Nothing+      Right t -> Just t +++--------------------------------------------------------------------------------+unifyTo1M :: Env -> [Sort] -> CheckM Sort +--------------------------------------------------------------------------------+unifyTo1M _ []     = panic "unifyTo1: empty list"+unifyTo1M f (t0:ts) = snd <$> foldM step (emptySubst, t0) ts+  where +    step :: (TVSubst, Sort) -> Sort -> CheckM (TVSubst, Sort)+    step (su, t) t' = do +      su' <- unify1 f Nothing su t t' +      return (su', apply su' t)+++--------------------------------------------------------------------------------+unifySorts :: Sort -> Sort -> Maybe TVSubst+--------------------------------------------------------------------------------+unifySorts   = unifyFast False emptyEnv+  where+    emptyEnv = const $ die $ err dummySpan "SortChecl: lookup in Empty Env "+++--------------------------------------------------------------------------------+-- | Fast Unification; `unifyFast True` is just equality+--------------------------------------------------------------------------------+unifyFast :: Bool -> Env -> Sort -> Sort -> Maybe TVSubst+--------------------------------------------------------------------------------+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 :: HasCallStack => Env -> Maybe Expr -> [Sort] -> [Sort] -> CheckM TVSubst+--------------------------------------------------------------------------------+unifys f e = unifyMany f e emptySubst++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')++unify1 :: Env -> Maybe Expr -> TVSubst -> Sort -> Sort -> CheckM TVSubst+unify1 f e !θ (FVar !i) !t+  = unifyVar f e θ i t+unify1 f e !θ !t (FVar !i)+  = unifyVar f e θ i t+unify1 f e !θ (FApp !t1 !t2) (FApp !t1' !t2')+  = unifyMany f e θ [t1, t2] [t1', t2']+unify1 _ _ !θ (FTC !l1) (FTC !l2)+  | isListTC l1 && isListTC l2+  = return θ+unify1 f e !θ !t1@(FAbs _ _) !t2 = do+  !t1' <- instantiate t1+  unifyMany f e θ [t1'] [t2]+unify1 f e !θ !t1 t2@(FAbs _ _) = do+  !t2' <- instantiate t2+  unifyMany f e θ [t1] [t2']+unify1 _ _ !θ !s1 !s2+  | isString s1, isString s2+  = return θ+unify1 _ _ !θ !FInt  !FReal = return θ++unify1 _ _ !θ !FReal !FInt  = return θ++unify1 f e !θ !t FInt = do+  checkNumeric f t `withError` (errUnify e t FInt)+  return θ++unify1 f e !θ !FInt !t = do+  checkNumeric f t `withError` (errUnify e FInt t)+  return θ++unify1 f e !θ (FFunc !t1 !t2) (FFunc !t1' !t2') = do+  unifyMany f e θ [t1, t2] [t1', t2']++unify1 f e θ (FObj a) !t =+  checkEqConstr f e θ a t++unify1 f e θ !t (FObj a) =+  checkEqConstr f e θ a t++unify1 _ e θ !t1 !t2+  | t1 == t2+  = return θ+  | otherwise+  = throwErrorAt (errUnify e t1 t2)++subst :: Int -> Sort -> Sort -> Sort+subst !j !tj !t@(FVar !i)+  | i == j                  = tj+  | otherwise               = t++subst !j !tj (FApp !t1 !t2)  = FApp t1' t2'+  where+    !t1'                    = subst j tj t1+    !t2'                    = subst j tj t2++-- subst _ _  !(FTC l)         = FTC l+subst !j !tj (FFunc !t1 !t2) = FFunc t1' t2'+  where+    !t1'                    = subst j tj $! t1+    !t2'                    = subst j tj $! t2++subst !j !tj (FAbs !i !t)+  | i == j                  = FAbs i t+  | otherwise               = FAbs i t'+  where+    !t'                     = subst j tj t++subst _  _   !s             = s++--------------------------------------------------------------------------------+instantiate :: Sort -> CheckM Sort+--------------------------------------------------------------------------------+instantiate !t = go t+  where+    go (FAbs !i !t) = do+      !t'    <- instantiate t+      !v     <- fresh+      return  $ subst i (FVar v) t'+    go !t =+      return t++unifyVar :: Env -> Maybe Expr -> TVSubst -> Int -> Sort -> CheckM TVSubst+unifyVar _ _ θ !i !t@(FVar !j)+  = case lookupVar i θ of+      Just !t'      -> if t == t' then return θ else return (updateVar j t' θ)+      Nothing       -> return (updateVar i t θ)++unifyVar f e θ !i !t+  = case lookupVar i θ of+      Just (FVar !j) -> return $ updateVar i t $ updateVar j t θ+      Just !t'       -> if t == t' then return θ else unify1 f e θ t t'+      Nothing        -> return (updateVar i t θ)++--------------------------------------------------------------------------------+-- | Applying a Type Substitution ----------------------------------------------+--------------------------------------------------------------------------------+apply :: TVSubst -> Sort -> Sort+--------------------------------------------------------------------------------+apply θ          = Vis.mapSort f+  where+    f t@(FVar i) = fromMaybe t (lookupVar i θ)+    f t          = t++applyExpr :: Maybe TVSubst -> Expr -> Expr+applyExpr Nothing e  = e+applyExpr (Just θ) e = Vis.mapExprOnExpr f e+  where+    f (ECst e s) = ECst e (apply θ s)+    f e          = e++--------------------------------------------------------------------------------+_applyCoercion :: Symbol -> Sort -> Sort -> Sort+--------------------------------------------------------------------------------+_applyCoercion a t = Vis.mapSort f+  where+    f (FObj b)+      | a == b    = t+    f s           = s+++--------------------------------------------------------------------------------+-- | Deconstruct a function-sort -----------------------------------------------+--------------------------------------------------------------------------------+checkFunSort :: Sort -> CheckM (Sort, Sort, TVSubst)+checkFunSort (FAbs _ t)    = checkFunSort t+checkFunSort (FFunc t1 t2) = return (t1, t2, emptySubst)+checkFunSort (FVar i)      = do j <- fresh+                                k <- fresh+                                return (FVar j, FVar k, updateVar i (FFunc (FVar j) (FVar k)) emptySubst)+checkFunSort t             = throwErrorAt (errNonFunction 1 t)++--------------------------------------------------------------------------------+-- | API for manipulating Sort Substitutions -----------------------------------+--------------------------------------------------------------------------------++newtype TVSubst = Th (M.HashMap Int Sort) deriving (Show)++instance Semigroup TVSubst where+  (Th s1) <> (Th s2) = Th (s1 <> s2)++instance Monoid TVSubst where+  mempty  = Th mempty+  mappend = (<>)++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)++emptySubst :: TVSubst+emptySubst = Th M.empty++--------------------------------------------------------------------------------+-- | Error messages ------------------------------------------------------------+--------------------------------------------------------------------------------++errElabExpr   :: Expr -> String+errElabExpr e = printf "Elaborate fails on %s" (showpp e)++errUnifyMsg :: Maybe String -> Maybe Expr -> Sort -> Sort -> String+errUnifyMsg msgMb eo t1 t2 +  = printf "Cannot unify %s with %s %s %s"+      (showpp t1) {- (show t1) -} (showpp t2) {-(show t2)-} (errUnifyExpr eo) msgStr+    where +      msgStr = case msgMb of { Nothing -> ""; Just s -> "<< " ++ s ++ " >>"} ++errUnify :: Maybe Expr -> Sort -> Sort -> String+errUnify = errUnifyMsg Nothing ++errUnifyExpr :: Maybe Expr -> String+errUnifyExpr Nothing  = ""+errUnifyExpr (Just e) = "in expression: " ++ showpp e++errUnifyMany :: [Sort] -> [Sort] -> String+errUnifyMany ts ts'  = printf "Cannot unify types with different cardinalities %s and %s"+                         (showpp ts) (showpp ts')++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+errOp e t t'+  | t == t'          = printf "Operands have non-numeric types %s in %s"+                         (showpp t) (showpp e)+  | otherwise        = printf "Operands have different types %s and %s in %s"+                         (showpp t) (showpp t') (showpp e)++errIte :: Expr -> Expr -> Sort -> Sort -> String+errIte e1 e2 t1 t2   = printf "Mismatched branches in Ite: then %s : %s, else %s : %s"+                         (showpp e1) (showpp t1) (showpp e2) (showpp t2)++errCast :: Expr -> Sort -> Sort -> String+errCast e t' t       = printf "Cannot cast %s of sort %s to incompatible sort %s"+                         (showpp e) (showpp t') (showpp t)++errUnboundAlts :: Symbol -> [Symbol] -> String+errUnboundAlts x xs  = printf "Unbound symbol %s --- perhaps you meant: %s ?"+                         (showpp x) (L.intercalate ", " (showpp <$> xs))++errNonFunction :: Int -> Sort -> String+errNonFunction i t   = printf "The sort %s is not a function with at least %s arguments\n" (showpp t) (showpp i)++errNonNumeric :: Sort -> String+errNonNumeric  l     = printf "The sort %s is not numeric" (showpp l)++errNonNumerics :: Symbol -> Symbol -> String+errNonNumerics l l'  = printf "FObj sort %s and %s are different and not numeric" (showpp l) (showpp l')++errNonFractional :: Sort -> String+errNonFractional  l  = printf "The sort %s is not fractional" (showpp l)++errBoolSort :: Expr -> Sort -> String+errBoolSort     e s  = printf "Expressions %s should have bool sort, but has %s" (showpp e) (showpp s)
src/Language/Fixpoint/Types.hs view
@@ -5,7 +5,6 @@  module Language.Fixpoint.Types (module X) where -import Language.Fixpoint.Types.SMTPrint         as X import Language.Fixpoint.Types.PrettyPrint      as X import Language.Fixpoint.Types.Names            as X import Language.Fixpoint.Types.Errors           as X@@ -19,4 +18,3 @@ import Language.Fixpoint.Types.Triggers         as X import Language.Fixpoint.Types.Theories         as X import Language.Fixpoint.Types.Templates        as X-import Language.Fixpoint.Types.Binders          as X
+ 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/Binders.hs 
@@ -1,10 +0,0 @@-module Language.Fixpoint.Types.Binders where--import Data.Hashable (Hashable)--class (Eq b, Ord b, Hashable b) => Binder b where-  wildcard :: b-  editDistance :: b -> b -> Int-  editDistance b1 b2-    | b1 == b2  = 0-    | otherwise = maxBound
src/Language/Fixpoint/Types/Config.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE DeriveGeneric             #-}-{-# LANGUAGE TemplateHaskell           #-}  module Language.Fixpoint.Types.Config (     Config  (..)@@ -13,20 +13,11 @@    -- * SMT Solver options   , SMTSolver (..)-  , solverFlags, mkElabFlags-  , ElabFlags (..) -  -- REST Options-  , RESTOrdering (..)-  , restOC-   -- * Eliminate options   , Eliminate (..)   , useElim -  -- * Scrape options-  , Scrape (..)-   -- * parallel solving options   , defaultMinPartSize   , defaultMaxPartSize@@ -35,23 +26,26 @@   , queryFile ) where -import qualified Data.Store as S-import qualified Data.List as L import Data.Serialize                (Serialize (..))-import Control.DeepSeq+import Control.Monad import GHC.Generics-import System.Console.GetOpt-import Language.Fixpoint.Verbosity   (Verbosity (..), setVerbosity, whenNormal)-import System.Environment            (getArgs)-import System.Exit                   (exitFailure, exitSuccess)+import System.Console.CmdArgs+import System.Console.CmdArgs.Explicit+import System.Environment -import qualified Language.Fixpoint.Conditional.Z3 as Conditional.Z3 import Language.Fixpoint.Utils.Files-import Development.GitRev (gitHash)-import Data.Version (showVersion)-import Paths_liquid_fixpoint (version) + --------------------------------------------------------------------------------+withPragmas :: Config -> [String] -> IO Config+--------------------------------------------------------------------------------+withPragmas = foldM withPragma++withPragma :: Config -> String -> IO Config+withPragma c s = withArgs [s] $ cmdArgsRun+          config { modeValue = (modeValue config) { cmdArgsValue = c } }++-------------------------------------------------------------------------------- -- | Configuration Options ----------------------------------------------------- -------------------------------------------------------------------------------- @@ -69,11 +63,11 @@   , maxPartSize :: Int                 -- ^ Maximum size of a partition. Overrides minPartSize   , solver      :: SMTSolver           -- ^ which SMT solver to use   , linear      :: Bool                -- ^ not interpret div and mul in SMT+  , stringTheory :: Bool               -- ^ interpretation of string theory by SMT   , defunction  :: Bool                -- ^ defunctionalize (use 'apply' for all uninterpreted applications)   , allowHO     :: Bool                -- ^ allow higher order binders in the logic environment   , allowHOqs   :: Bool                -- ^ allow higher order qualifiers   , eliminate   :: Eliminate           -- ^ eliminate non-cut KVars-  , scrape      :: Scrape              -- ^ configure auto-scraping of qualifiers from constraints   , elimBound   :: Maybe Int           -- ^ maximum length of KVar chain to eliminate   , smtTimeout  :: Maybe Int           -- ^ smt timeout in msec   , elimStats   :: Bool                -- ^ print eliminate stats@@ -86,97 +80,44 @@   , minimizeQs  :: Bool                -- ^ min .fq by delta debug (sat with min qualifiers)   , minimizeKs  :: Bool                -- ^ min .fq by delta debug (sat with min kvars)   , minimalSol  :: Bool                -- ^ shrink final solution by pruning redundant qualfiers from fixpoint-  , etaElim     :: Bool                -- ^ eta eliminate function definitions+  , etaElim     :: Bool                -- ^ eta eliminate function definitions +  , gradual     :: Bool                -- ^ solve "gradual" constraints+  , ginteractive :: Bool                -- ^ interactive gradual solving   , autoKuts         :: Bool           -- ^ ignore given kut variables   , nonLinCuts       :: Bool           -- ^ Treat non-linear vars as cuts   , noslice          :: Bool           -- ^ Disable non-concrete KVar slicing   , rewriteAxioms    :: Bool           -- ^ Allow axiom instantiation via rewriting-  , pleUndecGuards   :: Bool           -- ^ Unfold invocations with undecided guards in PLE-  , etabeta          :: Bool           -- ^ Eta expand and beta reduce terms to aid PLE-  , localRewrites    :: Bool           -- ^ Eta expand and beta reduce terms to aid PLE-  , saveBfqOnError   :: Bool           -- ^ save FInfo as .bfq only on verification failure-  , interpreter      :: Bool           -- ^ Use the interpreter to assist PLE-  , noEnvReduction   :: Bool     -- ^ Don't use environment reduction-  , inlineANFBinds   :: Bool          -- ^ Inline ANF bindings.+  , oldPLE           :: Bool           -- ^ Use old version of PLE+  , noIncrPle        :: Bool           -- ^ Use incremental PLE+  , noEnvironmentReduction :: Bool     -- ^ Don't use environment reduction+  , inlineANFBindings :: Bool          -- ^ Inline ANF bindings.                                        -- Sometimes improves performance and sometimes worsens it.-  , checkCstr        :: [Integer]      -- ^ Only check these specific constraints+  , checkCstr        :: [Integer]      -- ^ Only check these specific constraints    , extensionality   :: Bool           -- ^ Enable extensional interpretation of function equality-  , rwTermination    :: Bool        -- ^ Enable termination checking for rewriting-  , stdin               :: Bool        -- ^ Read input query from stdin+  , 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)-  , restOrdering        :: String      -- ^ Term ordering for use in REST-  , noStringTheory :: Bool             -- ^ disable interpretation of string theory by SMT-  , explicitKvars  :: Bool             -- ^ use explicitly declared kvars (horn style) which disables several "defensive simplifications"-  , sortedSolution :: Bool             -- ^ leave sorts in the solution-  , saveDir        :: Maybe FilePath    -- ^ output directory for --save generated files (default: .liquid/ next to source)-  } deriving (Eq,Show,Generic)-------------------------------------------------------------------------------------------data RESTOrdering = RESTKBO | RESTLPO | RESTRPO | RESTFuel Int-                 deriving (Eq, Generic)--instance Show RESTOrdering where-  show RESTKBO      = "kbo"-  show RESTLPO      = "lpo"-  show RESTRPO      = "rpo"-  show (RESTFuel n) = "fuel" ++ show n+  } deriving (Eq,Data,Typeable,Show,Generic) -instance Read RESTOrdering where-  readsPrec _ s | "kbo" `L.isPrefixOf` s = [(RESTKBO, drop 3 s)]-  readsPrec _ s | "lbo" `L.isPrefixOf` s = [(RESTLPO, drop 3 s)]-  readsPrec _ s | "rpo" `L.isPrefixOf` s = [(RESTRPO, drop 3 s)]-  readsPrec n s | "fuel" `L.isPrefixOf` s = do-                        (fuel', rest) <- readsPrec n (drop 4 s)-                        return (RESTFuel fuel', rest)-  readsPrec _ _ = []+instance Default Config where+  def = defConfig  --------------------------------------------------------------------------------------- -data SMTSolver = Z3 | Z3mem | Cvc4 | Cvc5 | Mathsat-                 deriving (Eq, Generic)--data ElabFlags = ElabFlags { elabSetBag :: Bool, elabExplicitKvars :: Bool }--mkElabFlags :: SMTSolver -> Bool -> ElabFlags-mkElabFlags slv expKvars = ElabFlags (setBag slv) expKvars-  where-    setBag Z3    = True-    setBag Z3mem = True-    setBag _     = False+data SMTSolver = Z3 | Cvc4 | Mathsat+                 deriving (Eq, Data, Typeable, Generic) -solverFlags :: Config -> ElabFlags-solverFlags cfg = mkElabFlags (solver cfg) (explicitKvars cfg)+instance Default SMTSolver where+  def = Z3  instance Show SMTSolver where   show Z3      = "z3"-  show Z3mem   = "z3 API"   show Cvc4    = "cvc4"-  show Cvc5    = "cvc5"   show Mathsat = "mathsat" -instance S.Store SMTSolver- ------------------------------------------------------------------------------------------ | `Scrape` describes which (Horn) constraints to scrape qualifiers from---   No   = do not scrape, only use the supplied qualifiers---   Head = scrape only from the constraint heads (i.e. "rhs")---   Both = scrape all concrete predicates (i.e. "rhs" + "lhs")--data Scrape = No | Head | Both-  deriving (Eq, Generic)--instance Serialize Scrape-instance S.Store Scrape-instance NFData Scrape--instance Show Scrape where-  show No   = "no"-  show Head = "head"-  show Both = "both"----------------------------------------------------------------------------------------- -- | Eliminate describes the number of KVars to eliminate: --   None = use PA/Quals for ALL k-vars, i.e. no eliminate --   Some = use PA/Quals for CUT k-vars, i.e. eliminate non-cuts@@ -190,13 +131,13 @@   | All   | Horn   | Existentials-  deriving (Eq, Generic)+  deriving (Eq, Data, Typeable, Generic)  instance Serialize Eliminate-instance S.Store Eliminate-instance NFData SMTSolver-instance NFData Eliminate +instance Default Eliminate where+  def = None+ instance Show Eliminate where   show None = "none"   show Some = "some"@@ -211,317 +152,84 @@ ---------------------------------------------------------------------------------------  defConfig :: Config-defConfig = Config-  { srcFile            = "out"-  , defunction         = False-  , solver             = if Conditional.Z3.builtWithZ3AsALibrary then Z3mem else Z3-  , linear             = False-  , noStringTheory     = False-  , allowHO            = False-  , allowHOqs          = False-  , eliminate          = None-  , scrape             = No-  , elimBound          = Nothing-  , smtTimeout         = Nothing-  , elimStats          = False-  , solverStats        = False-  , save               = False-  , saveBfqOnError     = False-  , saveDir            = Nothing-  , metadata           = False-  , stats              = False-  , etaElim            = False-  , parts              = False-  , cores              = Nothing-  , minPartSize        = defaultMinPartSize-  , maxPartSize        = defaultMaxPartSize-  , minimize           = False-  , minimizeQs         = False-  , minimizeKs         = False-  , minimalSol         = False-  , autoKuts           = False-  , nonLinCuts         = False-  , noslice            = False-  , rewriteAxioms      = False-  , pleUndecGuards     = False-  , interpreter        = False-  , etabeta            = False-  , localRewrites      = False-  , noEnvReduction     = False-  , inlineANFBinds     = False-  , checkCstr          = []-  , extensionality     = False-  , rwTermination      = False-  , stdin              = False-  , json               = False-  , fuel               = Nothing-  , restOrdering       = "rpo"-  , explicitKvars      = False-  , sortedSolution     = False+defConfig = Config {+    srcFile                  = "out"   &= args    &= typFile+  , defunction               = False   &= help "Allow higher order binders into fixpoint environment"+  , solver                   = def     &= help "Name of SMT Solver"+  , linear                   = False   &= help "Use uninterpreted integer multiplication and division"+  , stringTheory             = False   &= help "Interpretation of String Theory by SMT"+  , allowHO                  = False   &= help "Allow higher order binders into fixpoint environment"+  , allowHOqs                = False   &= help "Allow higher order qualifiers"+  , eliminate                = None    &= help "Eliminate KVars [none = quals for all-kvars, cuts = quals for cut-kvars, all = eliminate all-kvars (TRUE for cuts)]"+  , elimBound                = Nothing &= name "elimBound"   &= help "(alpha) Maximum eliminate-chain depth"+  , smtTimeout               = Nothing &= name "smtTimeout"  &= help "smt timeout in msec"+  , elimStats                = False   &= help "(alpha) Print eliminate stats"+  , solverStats              = False   &= help "Print solver stats"+  , save                     = False   &= help "Save Query as .fq and .bfq files"+  , metadata                 = False   &= help "Print meta-data associated with constraints"+  , stats                    = False   &= help "Compute constraint statistics"+  , etaElim                  = False   &= help "eta elimination in function definition"+  , parts                    = False   &= help "Partition constraints into indepdendent .fq files"+  , cores                    = def     &= help "(numeric) Number of threads to use"+  , minPartSize              = defaultMinPartSize &= help "(numeric) Minimum partition size when solving in parallel"+  , maxPartSize              = defaultMaxPartSize &= help "(numeric) Maximum partiton size when solving in parallel."+  , minimize                 = False &= help "Delta debug to minimize fq file (unsat with min constraints)"+  , minimizeQs               = False &= help "Delta debug to minimize fq file (sat with min qualifiers)"+  , minimizeKs               = False &= help "Delta debug to minimize fq file (sat with max kvars replaced by True)"+  , minimalSol               = False &= help "Shrink fixpoint by removing implied qualifiers"+  , gradual                  = False &= help "Solve gradual-refinement typing constraints"+  , ginteractive             = False &= help "Interactive Gradual Solving"+  , autoKuts                 = False &= help "Ignore given Kut vars, compute from scratch"+  , nonLinCuts               = False &= help "Treat non-linear kvars as cuts"+  , noslice                  = False &= help "Disable non-concrete KVar slicing"+  , rewriteAxioms            = False &= help "allow axiom instantiation via rewriting"+  , 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"+  , 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"   }---- | An individual parsed flag (modifier to Config, verbosity change, or exit).-data FxFlag-  = FxMod (Config -> Config)-  | FxVerbosity Verbosity-  | FxHelp-  | FxVersion-  | FxNumericVersion---- | All command-line options for fixpoint.-fxOptions :: [OptDescr FxFlag]-fxOptions =-  [ Option [] ["defunction", "defunct"] (NoArg (FxMod $ \c -> c { defunction = True }))-      "Allow higher order binders into fixpoint environment"-  , opt0 "linear"                  (\c -> c { linear            = True  })-      "Use uninterpreted integer multiplication and division"-  , opt0 "no-string-theory"        (\c -> c { noStringTheory    = True  })-      "Disable use of string theory by SMT"-  , opt0 "allowho"                 (\c -> c { allowHO           = True  })-      "Allow higher order binders into fixpoint environment"-  , opt0 "allowhoqs"               (\c -> c { allowHOqs         = True  })-      "Allow higher order qualifiers"-  , Option [] ["eliminate"]        (ReqArg setEliminate "ELIM")-      ( unlines-          [ "Eliminate KVars [" ++ L.intercalate " | "-            ["none", "some", "all", "horn", "existentials"] ++ "]"-          , "    none: quals for all-kvars"-          , "    some: ??"-          , "    all: eliminate all-kvars (TRUE for cuts)"-          , "    horn: ??"-          , "    existentials: ??"-          ]-      )-  , Option [] ["scrape"]           (ReqArg setScrape "SCRAPE")-      (unlines-        [ "Scrape qualifiers from constraint [" ++ L.intercalate " | "-          ["no", "head", "both"] ++ "]"-        , "    no: do not"-        , "    head: scrape from heads"-        , "    both: scrape from everywhere"-        ]-      )-  , Option [] ["solver"]           (ReqArg setSolver "SOLVER")-      ("SMT solver [" ++ L.intercalate " | " ["z3", "z3mem", "cvc4", "cvc5", "mathsat"] ++ "]")-  , Option [] ["elimBound"]        (ReqArg (\s -> FxMod $ \c -> c { elimBound   = parseInt "elimBound" s }) "N")-      "(alpha) Maximum eliminate-chain depth"-  , Option [] ["smtTimeout"]       (ReqArg (\s -> FxMod $ \c -> c { smtTimeout  = parseInt "smtTimeout" s }) "N")-      "SMT timeout in msec"-  , opt0 "elim-stats"              (\c -> c { elimStats     = True })-      "(alpha) Print eliminate stats"-  , opt0 "solver-stats"            (\c -> c { solverStats   = True })-      "Print solver stats"-  , opt0 "save"                    (\c -> c { save          = True })-      "Save Query as .fq and .bfq files"-  , Option [] ["save-bfq-on-error"] (NoArg (FxMod $ \c -> c { saveBfqOnError = True }))-      "Save Query as .bfq file only when verification fails"-  , Option [] ["save-dir"]         (ReqArg setSaveDir "DIR")-      "Output directory for --save generated files (default: .liquid/ next to source)"-  , opt0 "metadata"                (\c -> c { metadata      = True })-      "Print meta-data associated with constraints"-  , opt0 "stats"                   (\c -> c { stats         = True })-      "Compute constraint statistics"-  , Option [] ["eta-elim", "etaelim"] (NoArg (FxMod $ \c -> c { etaElim = True }))-      "Eta elimination in function definition"-  , opt0 "parts"                   (\c -> c { parts         = True })-      "Partition constraints into independent .fq files"-  , Option [] ["cores"]            (ReqArg (\s -> FxMod $ \c -> c { cores = parseInt "cores" s }) "N")-      "(numeric) Number of threads to use"-  , Option [] ["min-part-size"]    (ReqArg (\s -> FxMod $ \c -> c { minPartSize = read s }) "N")-      "(numeric) Minimum partition size when solving in parallel"-  , Option [] ["max-part-size"]    (ReqArg (\s -> FxMod $ \c -> c { maxPartSize = read s }) "N")-      "(numeric) Maximum partition size when solving in parallel"-  , opt0 "minimize"                (\c -> c { minimize       = True })-      "Delta debug to minimize fq file (unsat with min constraints)"-  , opt0 "minimize-qs"             (\c -> c { minimizeQs    = True })-      "Delta debug to minimize fq file (sat with min qualifiers)"-  , opt0 "minimize-ks"             (\c -> c { minimizeKs    = True })-      "Delta debug to minimize fq file (sat with max kvars replaced by True)"-  , opt0 "minimal-sol"             (\c -> c { minimalSol    = True })-      "Shrink fixpoint by removing implied qualifiers"-  , opt0 "auto-kuts"               (\c -> c { autoKuts      = True })-      "Ignore given Kut vars, compute from scratch"-  , opt0 "non-lin-cuts"            (\c -> c { nonLinCuts    = True })-      "Treat non-linear kvars as cuts"-  , opt0 "noslice"                 (\c -> c { noslice       = True })-      "Disable non-concrete KVar slicing"-  , Option [] ["ple", "rewrite", "rewrite-axioms"] (NoArg (FxMod $ \c -> c { rewriteAxioms = True }))-      "Allow axiom instantiation via rewriting (PLE)"-  , Option [] ["ple-with-undecided-guards"] (NoArg (FxMod $ \c -> c { pleUndecGuards = True }))-      "Unfold invocations with undecided guards in PLE"-  -- Accept optional =true/=false for backward compatibility with cmdargs Bool encoding-  , Option [] ["interpreter"]      (OptArg (parseBoolOpt interpreter (\b c -> c { interpreter = b })) "BOOL")-      "Use the interpreter to assist PLE"-  , opt0 "etabeta"                 (\c -> c { etabeta        = True })-      "Use eta expansion and beta reduction to aid PLE"-  , Option [] ["local-rewrites", "localrewrites"] (NoArg (FxMod $ \c -> c { localRewrites = True }))-      "Perform local rewrites inside PLE"-  , opt0 "no-env-reduction"        (\c -> c { noEnvReduction = True })-      "Don't perform environment reduction"-  , opt0 "inline-anf-binds"        (\c -> c { inlineANFBinds = True })-      "Inline ANF bindings (sometimes improves performance, sometimes worsens it)"-  , Option [] ["check-cstr"]       (ReqArg (\s -> FxMod $ \c -> c { checkCstr = checkCstr c ++ [read s] }) "ID")-      "Only check these specific constraint-ids (repeat for multiple)"-  , opt0 "extensionality"          (\c -> c { extensionality = True })-      "Allow extensional interpretation of function equality"-  , opt0 "rw-termination"          (\c -> c { rwTermination  = True })-      "Enable rewrite divergence checker"-  , opt0 "stdin"                   (\c -> c { stdin          = True })-      "Read input query from stdin"-  , opt0 "json"                    (\c -> c { json           = True })-      "Render result in JSON"-  , Option [] ["fuel"]             (ReqArg (\s -> FxMod $ \c -> c { fuel = parseInt "fuel" s }) "N")-      "Maximum fuel (per-function unfoldings) for PLE"-  , Option [] ["rest-ordering"]    (ReqArg (\s -> FxMod $ \c -> c { restOrdering = s }) "ORD")-      "Ordering constraint algebra to use for REST"-  , opt0 "explicit-kvars"          (\c -> c { explicitKvars  = True })-      "Use explicitly declared kvars (horn style) which disables several defensive simplifications"-  , opt0 "sorted-solution"         (\c -> c { sortedSolution = True })-      "Leave elaborated sorts in the solution (only for machine consumption)"-  , Option "v" ["verbose"]         (NoArg (FxVerbosity Loud))-      "Be more verbose"-  , Option "q" ["quiet"]           (NoArg (FxVerbosity Quiet))-      "Be quiet (suppress normal output)"-  , Option "h?" ["help"]           (NoArg FxHelp)-      "Show this help message"-  , Option "V" ["version"]         (NoArg FxVersion)-      "Show version"-  , Option [] ["numeric-version"]  (NoArg FxNumericVersion)-      "Print numeric version and exit"-  ]-  where-    opt0 name f desc =-      Option [] [name] (NoArg (FxMod f)) desc--    -- Parse an optional =true/=false/=True/=False argument (cmdargs Bool compat)-    parseBoolOpt :: (Config -> Bool) -> (Bool -> Config -> Config) -> Maybe String -> FxFlag-    parseBoolOpt _   setter Nothing          = FxMod (setter True)-    parseBoolOpt _   setter (Just "true")    = FxMod (setter True)-    parseBoolOpt _   setter (Just "True")    = FxMod (setter True)-    parseBoolOpt _   setter (Just "false")   = FxMod (setter False)-    parseBoolOpt _   setter (Just "False")   = FxMod (setter False)-    parseBoolOpt getDef _setter (Just s)         =-      error $ "Expected true/false, got: " ++ s ++ " (current default: " ++ show (getDef defConfig) ++ ")"--    setSolver s   = FxMod $ \c -> c { solver    = parseSolver s }-    setEliminate s = FxMod $ \c -> c { eliminate = parseEliminate s }-    setScrape s   = FxMod $ \c -> c { scrape    = parseScrape s }-    setSaveDir s = FxMod $ \c -> c { saveDir   = Just s }--    parseSolver "z3"        = Z3-    parseSolver "z3mem"     = Z3mem-    parseSolver "cvc4"      = Cvc4-    parseSolver "cvc5"      = Cvc5-    parseSolver "mathsat"   = Mathsat-    parseSolver s           = error $ "Unknown solver: " ++ s--    parseEliminate "none"         = None-    parseEliminate "some"         = Some-    parseEliminate "all"          = All-    parseEliminate "horn"         = Horn-    parseEliminate "existentials" = Existentials-    parseEliminate s              = error $ "Unknown eliminate mode: " ++ s--    parseScrape "no"   = No-    parseScrape "head" = Head-    parseScrape "both" = Both-    parseScrape s      = error $ "Unknown scrape mode: " ++ s--    parseInt _    s = Just (read s)---- | Apply a list of parsed flags to a base Config; return updated config and---   verbosity change (if any).-applyFxFlags :: Config -> [FxFlag] -> IO Config-applyFxFlags base flags = do-  mapM_ applyVerbosity flags-  return $! L.foldl' applyMod base flags-  where-    applyMod c (FxMod f) = f c-    applyMod c _         = c-    applyVerbosity (FxVerbosity vb) = setVerbosity vb-    applyVerbosity _                = return ()-----------------------------------------------------------------------------------withPragmas :: Config -> [String] -> IO Config----------------------------------------------------------------------------------withPragmas base tokens =-  case getOpt Permute fxOptions tokens of-    (flags, _, [])   -> do-      -- We make fixpoint fail when given --version of --help pragmas to make-      -- it harder to miss that a file is not being checked.-      handleExits flags exitFailure (formatHelp fxOptions) summaryInfo-      applyFxFlags base flags-    (_, _, optErrs)  -> ioError $ userError $-        concat optErrs ++ "\nUse --help for usage information."----------------------------------------------------------------------------------+  &= verbosity+  &= program "fixpoint"+  &= help    "Predicate Abstraction Based Horn-Clause Solver"+  &= summary "fixpoint Copyright 2009-15 Regents of the University of California."+  &= details [ "Predicate Abstraction Based Horn-Clause Solver"+             , ""+             , "To check a file foo.fq type:"+             , "  fixpoint foo.fq"+             ] -summaryInfo :: String-summaryInfo = "fixpoint " ++ showVersion version ++ " " ++ "(" ++ $(gitHash) ++ ")"+config :: Mode (CmdArgs Config)+config = cmdArgsMode defConfig  getOpts :: IO Config-getOpts = do-  args <- getArgs-  case getOpt Permute fxOptions args of-    (flags, files, []) -> do-      cfg <- applyFxFlags defConfig flags-      let srcF = case files of { (f:_) -> f; [] -> srcFile defConfig }-          cfg' = cfg { srcFile = srcF }-      whenBanner flags $ whenNormal (putStrLn banner)-      handleExits flags exitSuccess (formatHelp fxOptions) summaryInfo-      return cfg'-    (_, _, optErrs)    -> ioError $ userError $-        concat optErrs ++ "\nUse --help for usage information."--whenBanner :: [FxFlag] -> IO () -> IO ()-whenBanner (FxNumericVersion:_) _ = return ()-whenBanner (_:flags)   act = whenBanner flags act-whenBanner [] act          = act--handleExits :: [FxFlag] -> IO () -> String -> String -> IO ()-handleExits flags termination helpText ver = mapM_ go flags-  where-    go FxHelp           = putStr helpText >> termination-    go FxVersion        = putStrLn ver      >> termination-    go FxNumericVersion = putStrLn (showVersion version) >> termination-    go _                = return ()--formatHelp :: [OptDescr a] -> String-formatHelp opts =-    unlines $-      [ "Usage: fixpoint [OPTIONS] FILE.fq"-      , ""-      , "    Predicate Abstraction Based Horn-Clause Solver"-      , ""-      , "Options:"-      , ""-      ]-      ++ L.intersperse "" (map fmtOpt opts)-  where-    fmtOpt :: OptDescr a -> String-    fmtOpt (Option short long argDesc desc) =-      let shortStr = case short of-                       []    -> ""-                       (c:_) -> "-" ++ [c]-          longStrs  = map ("--" ++) long-          argStr    = case argDesc of-                        NoArg  _   -> ""-                        ReqArg _ m -> " " ++ m-                        OptArg _ m -> "[=" ++ m ++ "]"-          indentedDesc = unlines $ map ("        " ++) $ lines desc-          synopsis  = L.intercalate ", " $-                        [shortStr | not (null shortStr)] ++ longStrs-      in "  " ++ synopsis ++ argStr ++ "\n\n" ++ indentedDesc+getOpts = do +  md <- cmdArgs defConfig+  whenNormal (putStrLn banner)+  return md  banner :: String-banner =  "\nLiquid-Fixpoint Copyright 2009-25 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" -restOC :: Config -> RESTOrdering-restOC cfg = read (restOrdering cfg)- multicore :: Config -> Bool multicore cfg = cores cfg /= Just 1  queryFile :: Ext -> Config -> FilePath-queryFile e cfg = extFileNameR' (saveDir cfg) e (srcFile cfg)+queryFile e = extFileName e . srcFile
src/Language/Fixpoint/Types/Constraints.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -12,9 +12,6 @@ {-# LANGUAGE GADTs                      #-} {-# LANGUAGE PatternGuards              #-} -{-# OPTIONS_GHC -Wno-name-shadowing     #-}-{-# LANGUAGE RecordWildCards #-}- -- | This module contains the top-level QUERY data types and elements, --   including (Horn) implication & well-formedness constraints and sets. module Language.Fixpoint.Types.Constraints (@@ -23,19 +20,18 @@     FInfo, SInfo, GInfo (..), FInfoWithOpts(..)   , convertFormat   , sinfoToFInfo+  , Solver     -- * Serializing   , toFixpoint   , writeFInfo   , saveQuery-  , saveBinaryQuery-  , saveSInfo     -- * Constructing Queries   , fi    -- * Constraints-  , WfC (..)+  , WfC (..), isGWfc, updateWfCExpr   , SubC, SubcId   , mkSubC, subcId, sid, senv, updateSEnv, slhs, srhs, stag, subC, wfC   , SimpC (..)@@ -49,24 +45,23 @@   , addIds   , sinfo   , shiftVV+  , gwInfo, GWInfo (..)    -- * Qualifiers-  , Qualifier-  , QualifierV  (..)+  , Qualifier   (..)   , QualParam   (..)   , QualPattern (..)   , trueQual   , qualifier   , mkQual   , remakeQual-  , mkQ+  , mkQ    , qualBinds    -- * Results   , FixSolution-  , FixDelayedSolution-  , Delayed (..)-  , Result (..), ResultSorts+  , GFixSolution, toGFixSol+  , Result (..)   , unsafe, isUnsafe, isSafe ,safe    -- * Cut KVars@@ -77,34 +72,28 @@   , HOInfo (..)   , allowHO   , allowHOquals-  , cfgHoInfo    -- * Axioms   , AxiomEnv (..)-  , Equation-  , DefinedFuns (..)-  , EquationV (..)+  , Equation (..)   , mkEquation   , Rewrite  (..)   , AutoRewrite (..)   , dedupAutoRewrites-  , LocalRewritesEnv (..)-  , LocalRewrites (..)-  , lookupRewrite-  , lookupLocalRewrites-  , insertRewrites-  , eqnToHornSMT    -- * Misc  [should be elsewhere but here due to dependencies]   , substVars   , sortVars   , gSorts-   ) where  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@@ -112,17 +101,16 @@ import qualified Data.List                 as L -- (sort, nub, delete) import           Data.Maybe                (catMaybes) import           Control.DeepSeq-import           Control.Monad             (when, void)+import           Control.Monad             (void) import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Types.SMTPrint-import qualified Language.Fixpoint.Types.Config as C+import           Language.Fixpoint.Types.Config hiding (allowHO) import           Language.Fixpoint.Types.Triggers import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.Errors import           Language.Fixpoint.Types.Spans import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Types.Refinements-import           Language.Fixpoint.Types.Substitutions()+import           Language.Fixpoint.Types.Substitutions import           Language.Fixpoint.Types.Environments import qualified Language.Fixpoint.Utils.Files as Files import qualified Language.Fixpoint.Solver.Stats as Solver@@ -132,8 +120,6 @@ import qualified Data.HashMap.Strict       as M import qualified Data.HashSet              as S import qualified Data.ByteString           as B-import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified Data.Binary as B  --------------------------------------------------------------------------------@@ -148,8 +134,38 @@                     , wrft  :: (Symbol, Sort, KVar)                     , winfo :: !a                     }+             | GWfC { wenv  :: !IBindEnv+                    , wrft  :: !(Symbol, Sort, KVar)+                    , winfo :: !a+                    , wexpr :: !Expr+                    , wloc  :: !GradInfo+                    }               deriving (Eq, Generic, Functor) +data GWInfo = GWInfo { gsym  :: Symbol+                     , gsort :: Sort+                     , gexpr :: Expr+                     , ginfo :: GradInfo+                     }+              deriving (Eq, Generic)++gwInfo :: WfC a -> GWInfo+gwInfo (GWfC _ (x,s,_) _ e i)+  = GWInfo x s e i+gwInfo _+  = errorstar "gwInfo"++updateWfCExpr :: (Expr -> Expr) -> WfC a -> WfC a+updateWfCExpr _ w@(WfC {})  = w+updateWfCExpr f w@(GWfC {}) = w{wexpr = f (wexpr w)}++isGWfc :: WfC a -> Bool+isGWfc (GWfC {}) = True+isGWfc (WfC  {}) = False++instance HasGradual (WfC a) where+  isGradual = isGWfc+ type SubcId = Integer  data SubC a = SubC@@ -172,10 +188,10 @@   }   deriving (Generic, Functor) -instance Loc a => Loc (SimpC a) where+instance Loc a => Loc (SimpC a) where    srcSpan = srcSpan . _cinfo -strengthenHyp :: SInfo a -> [(Integer, Expr)] -> BindEnv a+strengthenHyp :: SInfo a -> [(Integer, Expr)] -> SInfo a strengthenHyp si ies = strengthenBinds si bindExprs   where     bindExprs        = safeFromList "strengthenHyp" [ (subcBind si i, e) | (i, e) <- ies ]@@ -188,12 +204,12 @@   = errorstar $ "Unknown subcId in subcBind: " ++ show i  -strengthenBinds :: SInfo a -> M.HashMap BindId Expr -> BindEnv a-strengthenBinds si m = mapBindEnv f (bs si)+strengthenBinds :: SInfo a -> M.HashMap BindId Expr -> SInfo a+strengthenBinds si m = si { bs = mapBindEnv f (bs si) }   where-    f i (x, sr, l)   = case M.lookup i m of-                         Nothing -> (x, sr, l)-                         Just e  -> (x, strengthenSortedReft sr e, l)+    f i (x, sr)      = case M.lookup i m of+                         Nothing -> (x, sr)+                         Just e  -> (x, strengthenSortedReft sr e)  strengthenSortedReft :: SortedReft -> Expr -> SortedReft strengthenSortedReft (RR s (Reft (v, r))) e = RR s (Reft (v, pAnd [r, e]))@@ -215,7 +231,7 @@   sid   :: c a -> Maybe Integer   stag  :: c a -> Tag   sinfo :: c a -> a-  clhs  :: BindEnv a -> c a -> [(Symbol, SortedReft)]+  clhs  :: BindEnv -> c a -> [(Symbol, SortedReft)]   crhs  :: c a -> Expr  instance TaggedC SimpC a where@@ -248,87 +264,37 @@ -- | Solutions and Results --------------------------------------------------------------------------- --- | Since some solutions are expensive to compute, we wrap them in a--- "Delayed" type to compute them only if needed.-{- HLINT ignore Delayed "Use newtype instead of data" -}-data Delayed a = Delayed-  { forceDelayed  :: a-  }-  deriving (Generic, Show, Functor)+type GFixSolution = GFixSol Expr -instance (NFData a) => NFData (Delayed a)+type FixSolution  = M.HashMap KVar Expr +newtype GFixSol e = GSol (M.HashMap KVar (e, [e]))+  deriving (Generic, Semigroup, Monoid, Functor) -type FixSolution  = M.HashMap KVar Expr-type FixDelayedSolution  = M.HashMap KVar (Delayed Expr)+toGFixSol :: M.HashMap KVar (e, [e]) -> GFixSol e+toGFixSol = GSol -data Result a = Result++data Result a = Result    { resStatus    :: !(FixResult a)   , resSolution  :: !FixSolution-  , resNonCutsSolution :: !FixDelayedSolution-  , resSorts     :: !ResultSorts+  , resNonCutsSolution :: !FixSolution+  , gresSolution :: !GFixSolution    }   deriving (Generic, Show, Functor) -type ResultSorts = M.HashMap KVar [(Symbol, Sort)] -data ScopedResult = MkScopedResult-  { scCuts    :: KVarMap ScopedExpr-  , scNonCuts :: KVarMap ScopedExpr-  }-  deriving (Generic, Show) -newtype KVarMap a = MkKVarMap { unKVarMap :: M.HashMap KVar a }-  deriving (Generic, Show)--newtype KVarBind a = MkKVarBind { unKVarBind :: (KVar, a) }-  deriving (Generic, Show)-data ScopedExpr = MkScopedExpr-  { seParams :: [(Symbol, Sort)]-  , seBody :: !Expr-  }-  deriving (Generic, Show)--instance ToHornSMT ScopedExpr where-  toHornSMT (MkScopedExpr xts p) = toHornWithBinders "lambda" xts p---scopedResult :: Result a -> ScopedResult-scopedResult res = MkScopedResult cuts  nonCuts-  where-    cuts = scoped $ resSolution res-    nonCuts = scoped $ M.map forceDelayed $ resNonCutsSolution res-    scoped sol = MkKVarMap $ M.fromList [ (k, MkScopedExpr (scope k) e) | (k, e) <- M.toList sol]-    scope k = M.lookupDefault [] k $ resSorts res- instance ToJSON a => ToJSON (Result a) where-  toJSON r@(Result {..}) = object-    [ "status"            .= resStatus-    , "solution"          .= scCuts scopedSolution-    , "nonCutsSolution"   .= scNonCuts scopedSolution-    ]-    where-      scopedSolution = scopedResult r--instance ToJSON a => ToJSON (KVarBind a) where-  toJSON (MkKVarBind (k, v)) = object-    [ "kvar" .= k-    , "val"  .= v-    ]--instance ToJSON a => ToJSON (KVarMap a) where-  toJSON = toJSON . map MkKVarBind . M.toList . unKVarMap--instance ToJSON ScopedExpr where-  toJSON = toJSON . render . toHornSMT+  toJSON = toJSON . resStatus  instance Semigroup (Result a) where-  r1 <> r2  = Result stat soln nonCutsSoln sorts+  r1 <> r2  = Result stat soln nonCutsSoln gsoln     where-      stat  = resStatus r1    <> resStatus r2-      soln  = resSolution r1  <> resSolution r2+      stat  = (resStatus r1)    <> (resStatus r2)+      soln  = (resSolution r1)  <> (resSolution r2)       nonCutsSoln = resNonCutsSolution r1 <> resNonCutsSolution r2-      sorts = M.unionWith L.union (resSorts r1) (resSorts r2)+      gsoln = (gresSolution r1) <> (gresSolution r2)  instance Monoid (Result a) where   mempty        = Result mempty mempty mempty mempty@@ -349,9 +315,9 @@ isUnsafe _ = False  instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where-  toFix (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)"+  toFix (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)"    -- toFix (UnknownError d) = text $ "Unknown Error: " ++ d-  toFix (Crash xs msg)   = vcat $ [ text "Crash!" ] ++  pprSinfos "CRASH: " (fst <$> xs) ++ [parens (text msg)]+  toFix (Crash xs msg)   = vcat $ [ text "Crash!" ] ++  pprSinfos "CRASH: " xs ++ [parens (text msg)]   toFix (Unsafe _ xs)    = vcat $ text "Unsafe:" : pprSinfos "WARNING: " xs  pprSinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc]@@ -394,8 +360,9 @@   toFix w     = hang (text "\n\nwf:") 2 bd     where bd  =   toFix (wenv w)               -- NOTE: this next line is printed this way for compatability with the OCAML solver-              $+$ text "reft" <+> toFix (RR t (Reft (v, PKVar k M.empty mempty)))+              $+$ text "reft" <+> toFix (RR t (Reft (v, PKVar k mempty)))               $+$ toFixMeta (text "wf") (toFix (winfo w))+              $+$ if (isGWfc w) then (toFixMeta (text "expr") (toFix (wexpr w))) else mempty           (v, t, k) = wrft w  toFixMeta :: Doc -> Doc -> Doc@@ -405,22 +372,43 @@ pprId (Just i)  = "id" <+> tshow i pprId _         = "" +instance PPrint GFixSolution where+  pprintTidy k (GSol xs) = vcat $ punctuate "\n\n" (pprintTidyGradual k <$> M.toList xs)++pprintTidyGradual :: Tidy -> (KVar, (Expr, [Expr])) -> Doc+pprintTidyGradual _ (x, (e, es)) = ppLocOfKVar x <+> text ":=" <+> (ppNonTauto " && " e <-> pprint es)++ppLocOfKVar :: KVar -> Doc+ppLocOfKVar = text. dropWhile (/='(') . symbolString .kv++ppNonTauto :: Doc -> Expr -> Doc+ppNonTauto d e+  | isTautoPred e = mempty+  | otherwise     = pprint e <-> d++instance Show   GFixSolution where+  show = showpp+ -----------------------------------------------------------------instance S.Store QualPattern-instance S.Store QualParam+instance S.Store QualPattern +instance S.Store QualParam  instance S.Store Qualifier instance S.Store Kuts instance S.Store HOInfo+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-instance NFData v => NFData (QualifierV v)+instance NFData QualPattern +instance NFData QualParam +instance NFData Qualifier instance NFData Kuts instance NFData HOInfo+instance NFData GFixSolution+instance NFData GWInfo  instance (NFData a) => NFData (SubC a) instance (NFData a) => NFData (WfC a)@@ -428,35 +416,39 @@ instance (NFData (c a), NFData a) => NFData (GInfo c a) instance (NFData a) => NFData (Result a) -instance Hashable v => Hashable (QualifierV v)+instance Hashable Qualifier instance Hashable QualPattern instance Hashable QualParam-instance Hashable v => Hashable (EquationV v)+instance Hashable Equation  instance B.Binary QualPattern instance B.Binary QualParam-instance B.Binary v => B.Binary (QualifierV v)-instance B.Binary v => B.Binary (EquationV v)+instance B.Binary Qualifier  --------------------------------------------------------------------------- -- | "Smart Constructors" for Constraints --------------------------------- ---------------------------------------------------------------------------  wfC :: (Fixpoint a) => IBindEnv -> SortedReft -> a -> [WfC a]-wfC be sr x = if all isEmptyKVarSubst sus -- ++ gsus)+wfC be sr x = if all isEmptySubst sus -- ++ gsus)                  -- NV TO RJ This tests fails with [LT:=GHC.Types.LT][EQ:=GHC.Types.EQ][GT:=GHC.Types.GT]]                  -- NV TO RJ looks like a resolution issue                 then [WfC be (v, sr_sort sr, k) x      | k         <- ks ]+                  ++ [GWfC be (v, sr_sort sr, k) x e i | (k, e, i) <- gs ]                 else errorstar msg   where-    msg             = "wfKvar: malformed wfC " ++ show sr ++ "\n" ++ show sus+    msg             = "wfKvar: malformed wfC " ++ show sr ++ "\n" ++ show (sus ++ gsus)     Reft (v, ras)   = sr_reft sr     (ks, sus)       = unzip $ go ras+    (gs, gsus)      = unzip $ go' ras -    go (PKVar k _ su) = [(k, su)]-    go (PAnd es)    = [(k, su) | PKVar k _ su <- es]+    go (PKVar k su) = [(k, su)]+    go (PAnd es)    = [(k, su) | PKVar k su <- es]     go _            = [] +    go' (PGrad k su i e) = [((k, e, i), su)]+    go' (PAnd es)      = concatMap go' es+    go' _              = []  mkSubC :: IBindEnv -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> SubC a mkSubC = SubC@@ -481,108 +473,80 @@  addIds :: [SubC a] -> [(Integer, SubC a)] addIds = zipWith (\i c -> (i, shiftId i $ c {_sid = Just i})) [1..]-  where+  where      -- Adding shiftId to have distinct VV for SMT conversion-    shiftId i c = c { slhs = shiftSR i (slhs c) }-                    { srhs = shiftSR i (srhs c) }+    shiftId i c = c { slhs = shiftSR i $ slhs c }+                    { srhs = shiftSR i $ srhs c }     shiftSR i sr = sr { sr_reft = shiftR i $ sr_reft sr }     shiftR i r@(Reft (v, _)) = shiftVV r (intSymbol v i)  -------------------------------------------------------------------------------- -- | Qualifiers ---------------------------------------------------------------- ---------------------------------------------------------------------------------type Qualifier = QualifierV Symbol-data QualifierV v = Q+data Qualifier = Q    { qName   :: !Symbol     -- ^ Name   , qParams :: [QualParam] -- ^ Parameters-  , qBody   :: !(ExprV v)  -- ^ Predicate+  , qBody   :: !Expr       -- ^ Predicate   , qPos    :: !SourcePos  -- ^ Source Location   }-  deriving (Eq, Ord, Show, Data, Typeable, Generic, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Data, Typeable, Generic) -data QualParam = QP+data QualParam = QP    { qpSym  :: !Symbol-  , qpPat  :: !QualPattern+  , qpPat  :: !QualPattern    , qpSort :: !Sort-  }+  }    deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance ToHornSMT QualParam where-  toHornSMT qp = toHornSMT (qpSym qp, qpSort qp)---data QualPattern-  = PatNone                 -- ^ match everything+data QualPattern +  = PatNone                 -- ^ match everything    | PatPrefix !Symbol !Int  -- ^ str . $i  i.e. match prefix 'str' with suffix bound to $i   | PatSuffix !Int !Symbol  -- ^ $i . str  i.e. match suffix 'str' with prefix bound to $i   | PatExact  !Symbol       -- ^ str       i.e. exactly match 'str'-  | PatLit                  -- ^ match literals of the given sort   deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance ToJSON   Qualifier   where-instance FromJSON Qualifier   where-instance ToJSON   QualParam   where-instance FromJSON QualParam   where-instance ToJSON   QualPattern where-instance FromJSON QualPattern where-instance ToJSON   Equation    where-instance FromJSON Equation    where-instance ToJSON   Rewrite     where-instance FromJSON Rewrite     where--instance ToHornSMT Qualifier where-  toHornSMT (Q n qps p _) =  toHornWithBinders name xts p-    where-      name = "qualif" <+> pprint n-      xts =  [(qpSym qp, qpSort qp) | qp <- qps]- trueQual :: Qualifier-trueQual = Q (symbol ("QTrue" :: String)) [] PTrue (dummyPos "trueQual")+trueQual = Q (symbol ("QTrue" :: String)) [] mempty (dummyPos "trueQual")  instance Loc Qualifier where   srcSpan q = SS l l     where       l     = qPos q -instance Subable Qualifier where-  syms   = qualFreeSymbols+instance Subable Qualifier where +  syms   = qualFreeSymbols    subst  = mapQualBody . subst   substf = mapQualBody . substf   substa = mapQualBody . substa  mapQualBody :: (Expr -> Expr) -> Qualifier -> Qualifier mapQualBody f q = q { qBody = f (qBody q) }-+   qualFreeSymbols :: Qualifier -> [Symbol]-qualFreeSymbols q = filter (not . isPrim) xs+qualFreeSymbols q = filter (not . isPrim) xs    where-    xs            = syms (qBody q) L.\\ syms (qpSym <$> qParams q)+    xs            = syms (qBody q) L.\\ syms (qpSym <$> qParams q)  -instance Fixpoint QualParam where-  toFix (QP x _ t) = toFix (x, t)+instance Fixpoint QualParam where +  toFix (QP x _ t) = toFix (x, t)  -instance PPrint QualParam where-  pprintTidy k (QP x pat t) = pprintTidy k x <+> pprintTidy k pat <+> colon <+> pprintTidy k t+instance PPrint QualParam where +  pprintTidy k (QP x pat t) = pprintTidy k x <+> pprintTidy k pat <+> colon <+> pprintTidy k t  -instance PPrint QualPattern where-  pprintTidy _ PatNone         = ""+instance PPrint QualPattern where +  pprintTidy _ PatNone         = ""    pprintTidy k (PatPrefix s i) = "as" <+> pprintTidy k s <+> ("$" <-> pprint i)-  pprintTidy k (PatSuffix s i) = "as" <+> ("$" <-> pprint i) <+> pprintTidy k s-  pprintTidy k (PatExact  s  ) = "~"  <+> pprintTidy k s-  pprintTidy _ PatLit          = "as lit"+  pprintTidy k (PatSuffix s i) = "as" <+> ("$" <-> pprint i) <+> pprintTidy k s +  pprintTidy k (PatExact  s  ) = "~"  <+> pprintTidy k s   instance Fixpoint Qualifier where   toFix = pprQual -instance (Ord v, Fixpoint v, PPrint v) => PPrint (QualifierV v) where-  pprintTidy k q =-    "qualif" <+> pprintTidy k (qName q) <+>-     parens (hsep $ punctuate comma (pprintTidy k <$> qParams q)) <+>-     braces (pprintTidy k (qBody q)) <+> "//defined at" <+> pprintTidy k (qPos q)-+instance PPrint Qualifier where+  pprintTidy k q = "qualif" <+> pprintTidy k (qName q) <+> "defined at" <+> pprintTidy k (qPos q)  pprQual :: Qualifier -> Doc-pprQual (Q n xts p l) = text "qualif" <+> text (symbolString n) <-> parens args <-> braces (toFix p) <+> text "//" <+> toFix l+pprQual (Q n xts p l) = text "qualif" <+> text (symbolString n) <-> parens args <-> colon <+> parens (toFix p) <+> text "//" <+> toFix l   where     args              = intersperse comma (toFix <$> xts) @@ -592,7 +556,7 @@     xs  = L.delete v $ L.nub $ syms p     xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..] -mkQ :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier+mkQ :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier  mkQ n = Q n . qualParams  qualParams :: [(Symbol, Sort)] -> [QualParam]@@ -614,14 +578,14 @@ remakeQual q = mkQual (qName q) (qParams q) (qBody q) (qPos q)  -- | constructing qualifiers-mkQual :: Symbol -> [QualParam] -> ExprV v -> SourcePos -> QualifierV v-mkQual n qps p = Q n qps' p+mkQual :: Symbol -> [QualParam] -> Expr -> SourcePos -> Qualifier+mkQual n qps p = Q n qps' p    where     qps'       = zipWith (\qp t' -> qp { qpSort = t'}) qps ts'-    ts'        = gSorts (qpSort <$> qps)+    ts'        = gSorts (qpSort <$> qps)   gSorts :: [Sort] -> [Sort]-gSorts ts = substVars su <$> ts+gSorts ts = substVars su <$> ts    where     su    = (`zip` [0..]) . sortNub . concatMap sortVars $ ts @@ -667,7 +631,7 @@                deriving (Eq, Show, Generic)  instance Fixpoint Kuts where-  toFix (KS s) = vcat $ ("cut " <->) . toFix <$> L.sort (S.toList s)+  toFix (KS s) = vcat $ (("cut " <->) . toFix) <$> L.sort (S.toList s)  ksMember :: KVar -> Kuts -> Bool ksMember k (KS s) = S.member k s@@ -684,7 +648,7 @@ ------------------------------------------------------------------------ fi :: [SubC a]    -> [WfC a]-   -> BindEnv a+   -> BindEnv    -> SEnv Sort    -> SEnv Sort    -> Kuts@@ -695,11 +659,12 @@    -> [Triggered Expr]    -> AxiomEnv    -> [DataDecl]+   -> [BindId]     -> GInfo SubC a-fi cs ws binds ls ds ks qs bi aHO aHOq es axe adts+fi cs ws binds ls ds ks qs bi aHO aHOq es axe adts ebs   = FI { cm       = M.fromList $ addIds cs        , ws       = M.fromListWith err [(k, w) | w <- ws, let (_, _, k) = wrft w]-       , bs       = binds+       , bs       = foldr (adjustBindEnv stripReft) binds ebs        , gLits    = ls        , dLits    = ds        , kuts     = ks@@ -709,18 +674,18 @@        , asserts  = es        , ae       = axe        , ddecls   = adts-       , lrws     = mempty-       , defns    = mempty+       , ebinds   = ebs         }   where     --TODO handle duplicates gracefully instead (merge envs by intersect?)     err = errorstar "multiple WfCs with same kvar"+    stripReft (sym, reft) = (sym, reft { sr_reft = trueReft })  ------------------------------------------------------------------------ -- | Top-level Queries ------------------------------------------------------------------------ -data FInfoWithOpts a = FIO+data FInfoWithOpts a = FIO    { fioFI   :: FInfo a   , fioOpts :: [String]   }@@ -728,23 +693,21 @@ type FInfo a   = GInfo SubC a type SInfo a   = GInfo SimpC a -data HOInfo = HOI+data HOInfo = HOI    { hoBinds :: Bool          -- ^ Allow higher order binds in the environemnt   , hoQuals :: Bool          -- ^ Allow higher order quals   }   deriving (Eq, Show, Generic) -cfgHoInfo :: C.Config -> HOInfo-cfgHoInfo cfg = HOI (C.allowHO cfg) (C.allowHOqs cfg)- allowHO, allowHOquals :: GInfo c a -> Bool allowHO      = hoBinds . hoInfo allowHOquals = hoQuals . hoInfo -data GInfo c a = FI+data GInfo c a = FI    { cm       :: !(M.HashMap SubcId (c a))  -- ^ cst id |-> Horn Constraint   , ws       :: !(M.HashMap KVar (WfC a))  -- ^ Kvar  |-> WfC defining its scope/args-  , bs       :: !(BindEnv a)               -- ^ BindId  |-> (Symbol, SortedReft)+  , bs       :: !BindEnv                   -- ^ Bind  |-> (Symbol, SortedReft)+  , ebinds   :: ![BindId]                  -- ^ Subset of existential binders   , gLits    :: !(SEnv Sort)               -- ^ Global Constant symbols   , dLits    :: !(SEnv Sort)               -- ^ Distinct Constant symbols   , kuts     :: !Kuts                      -- ^ Set of KVars *not* to eliminate@@ -754,11 +717,12 @@   , hoInfo   :: !HOInfo                    -- ^ Higher Order info   , asserts  :: ![Triggered Expr]          -- ^ TODO: what is this?   , ae       :: AxiomEnv                   -- ^ Information about reflected function defs-  , lrws     :: LocalRewritesEnv           -- ^ Local rewrites-  , defns    :: DefinedFuns                -- ^ `define_fun` definitions to be passed to SMT   }   deriving (Eq, Show, Functor, Generic) +instance HasGradual (GInfo c a) where+  isGradual info = any isGradual (M.elems $ ws info)+ instance Semigroup HOInfo where   i1 <> i2 = HOI { hoBinds = hoBinds i1 || hoBinds i2                  , hoQuals = hoQuals i1 || hoQuals i2@@ -768,39 +732,37 @@   mempty        = HOI False False  instance Semigroup (GInfo c a) where-  i1 <> i2 = FI { cm       = cm i1       <> cm i2-                , ws       = ws i1       <> ws i2-                , bs       = bs i1       <> bs i2-                , gLits    = gLits i1    <> gLits i2-                , dLits    = dLits i1    <> dLits i2-                , kuts     = kuts i1     <> kuts i2-                , quals    = quals i1    <> quals i2-                , bindInfo = bindInfo i1 <> bindInfo i2-                , ddecls   = ddecls i1   <> ddecls i2-                , hoInfo   = hoInfo i1   <> hoInfo i2-                , asserts  = asserts i1  <> asserts i2-                , ae       = ae i1       <> ae i2-                , lrws     = lrws i1     <> lrws i2-                , defns    = defns i1    <> defns i2+  i1 <> i2 = FI { cm       = (cm i1)       <> (cm i2)+                , ws       = (ws i1)       <> (ws i2)+                , bs       = (bs i1)       <> (bs i2)+                , ebinds   = (ebinds i1)   <> (ebinds i2)+                , gLits    = (gLits i1)    <> (gLits i2)+                , dLits    = (dLits i1)    <> (dLits i2)+                , kuts     = (kuts i1)     <> (kuts i2)+                , quals    = (quals i1)    <> (quals i2)+                , bindInfo = (bindInfo i1) <> (bindInfo i2)+                , ddecls   = (ddecls i1)   <> (ddecls i2)+                , hoInfo   = (hoInfo i1)   <> (hoInfo i2)+                , asserts  = (asserts i1)  <> (asserts i2)+                , ae       = (ae i1)       <> (ae i2)                 }   instance Monoid (GInfo c a) where   mempty        = FI { cm       = M.empty-                     , ws       = mempty-                     , bs       = mempty-                     , gLits    = mempty-                     , dLits    = mempty-                     , kuts     = mempty-                     , quals    = mempty-                     , bindInfo = mempty-                     , ddecls   = mempty-                     , hoInfo   = mempty-                     , asserts  = mempty+                     , ws       = mempty +                     , bs       = mempty +                     , ebinds   = mempty +                     , gLits    = mempty +                     , dLits    = mempty +                     , kuts     = mempty +                     , quals    = mempty +                     , bindInfo = mempty +                     , ddecls   = mempty +                     , hoInfo   = mempty +                     , asserts  = mempty                       , ae       = mempty-                     , lrws     = mempty-                     , defns    = mempty-                     }+                     }   instance PTable (SInfo a) where   ptable z = DocTable [ (text "# Sub Constraints", pprint $ length $ cm z)@@ -810,12 +772,11 @@ -------------------------------------------------------------------------- -- | Rendering Queries ---------------------------------------------------------------------------toFixpoint :: (Fixpoint a, Fixpoint (c a)) => C.Config -> GInfo c a -> Doc+toFixpoint :: (Fixpoint a, Fixpoint (c a)) => Config -> GInfo c a -> Doc -------------------------------------------------------------------------- toFixpoint cfg x' =    cfgDoc   cfg                   $++$ declsDoc x'                   $++$ aeDoc    x'-                  $++$ lrwsDoc  x'                   $++$ qualsDoc x'                   $++$ kutsDoc  x'                 --   $++$ packsDoc x'@@ -835,17 +796,17 @@     kutsDoc       = toFix    . kuts     -- packsDoc      = toFix    . packs     declsDoc      = vcat     . map ((text "data" <+>) . toFix) . L.sort . ddecls-    bindsDoc      = toFix (bs x')+    (ubs, ebs)    = splitByQuantifiers (bs x') (ebinds x')+    bindsDoc      = toFix    ubs+               $++$ toFix    ebs     qualsDoc      = vcat     . map toFix . L.sort . quals     aeDoc         = toFix    . ae-    lrwsDoc       = toFix    . lrws     metaDoc (i,d) = toFixMeta (text "bind" <+> toFix i) (toFix d)-    mdata         = C.metadata cfg+    mdata         = metadata cfg     binfoDoc       | mdata     = vcat     . map metaDoc . M.toList . bindInfo       | otherwise = \_ -> text "\n" -infixl 9 $++$ ($++$) :: Doc -> Doc -> Doc x $++$ y = x $+$ text "\n" $+$ y @@ -854,7 +815,7 @@   where     kvD (c, so) = d <+> toFix c <+> ":" <+> parens (toFix so) -writeFInfo :: (Fixpoint a, Fixpoint (c a)) => C.Config -> GInfo c a -> FilePath -> IO ()+writeFInfo :: (Fixpoint a, Fixpoint (c a)) => Config -> GInfo c a -> FilePath -> IO () writeFInfo cfg fq f = writeFile f (render $ toFixpoint cfg fq)  --------------------------------------------------------------------------------@@ -881,7 +842,7 @@   where     fi'           = fi { bs = be', cm = cm' }     m'            = M.insert i bId m-    (bId, be')    = insertBindEnv x sr (sinfo c) (bs fi)+    (bId, be')    = insertBindEnv x sr $ bs fi     cm'           = M.insert i c' $ cm fi     c'            = c { _senv = insertsIBindEnv [bId] $ senv c }     sr            = slhs c@@ -900,7 +861,7 @@  -- Assumes the sort and the bind of the lhs is the same as the sort -- and the bind of the rhs-simpcToSubc :: BindEnv a -> SimpC a -> SubC a+simpcToSubc :: BindEnv -> SimpC a -> SubC a simpcToSubc env s = SubC   { _senv  = deleteIBindEnv (cbind s) (senv s)   , slhs   = sr@@ -910,49 +871,35 @@   , _sinfo = sinfo s   }   where-    (b, sr, _) = lookupBindEnv (cbind s) env+    (b, sr) = lookupBindEnv (cbind s) env +---------------------------------------------------------------------------+-- | Top level Solvers ----------------------------------------------------+---------------------------------------------------------------------------+type Solver a = Config -> FInfo a -> IO (Result (Integer, a))+ ---------------------------------------------------------------------------------saveQuery :: (Fixpoint a) => C.Config -> FInfo a -> IO ()+saveQuery :: Fixpoint a => Config -> FInfo a -> IO () ---------------------------------------------------------------------------------saveQuery cfg fi = when (C.save cfg) $ do+saveQuery cfg fi = {- when (save cfg) $ -} do   let fi'  = void fi   saveBinaryQuery cfg fi'   saveTextQuery cfg   fi -saveBinaryQuery :: C.Config -> FInfo () -> IO ()+saveBinaryQuery :: Config -> FInfo () -> IO () saveBinaryQuery cfg fi = do-  let bfq  = C.queryFile Files.BinFq cfg+  let bfq  = queryFile Files.BinFq cfg   putStrLn $ "Saving Binary Query: " ++ bfq ++ "\n"   ensurePath bfq   B.writeFile bfq (S.encode fi)+  -- B.encodeFile bfq fi -saveTextQuery :: Fixpoint a => C.Config -> FInfo a -> IO ()+saveTextQuery :: Fixpoint a => Config -> FInfo a -> IO () saveTextQuery cfg fi = do-  let fq   = C.queryFile Files.Fq cfg-  putStrLn $ "Saving Text Query: "   ++ fq ++ "\n"-  ensurePath fq-  T.writeFile fq $ T.pack $ render (toFixpoint cfg fi)---- | Used for debugging to inspect intermediate 'SInfo' files.------ Takes a suffix to put in the name of the written file, whose name--- is still derived from the input file name in `cfg`.------ Usage example:------ > when (save cfg) $--- >   saveSInfo cfg ".sinfo" si------ This will write a file like `.liquid/Test.hs.sinfo.fq` when the--- `--save` flag is used.----saveSInfo :: Fixpoint a => C.Config -> String -> SInfo a -> IO ()-saveSInfo cfg sfx si = do-  let fq = Files.tempFileName (C.srcFile cfg ++ sfx ++ ".fq")+  let fq   = queryFile Files.Fq cfg   putStrLn $ "Saving Text Query: "   ++ fq ++ "\n"   ensurePath fq-  T.writeFile fq $ T.pack $ render (toFixpoint cfg si)+  writeFile fq $ render (toFixpoint cfg fi)  --------------------------------------------------------------------------- -- | Axiom Instantiation Information --------------------------------------@@ -964,32 +911,18 @@   , aenvAutoRW   :: M.HashMap SubcId [AutoRewrite]   } deriving (Eq, Show, Generic) -newtype LocalRewrites = LocalRewrites (M.HashMap Symbol Expr)-  deriving (Eq, Show, Generic, Semigroup, Monoid, NFData, S.Store)--newtype LocalRewritesEnv = LocalRewritesMap (M.HashMap BindId LocalRewrites)-  deriving (Eq, Show, Generic, Semigroup, Monoid, NFData, S.Store)--lookupRewrite :: Symbol -> LocalRewrites -> Maybe Expr-lookupRewrite x (LocalRewrites m) = M.lookup x m--lookupLocalRewrites :: BindId -> LocalRewritesEnv -> Maybe LocalRewrites-lookupLocalRewrites i (LocalRewritesMap m) = M.lookup i m--insertRewrites :: BindId -> LocalRewrites -> LocalRewritesEnv -> LocalRewritesEnv-insertRewrites i rws (LocalRewritesMap m) = LocalRewritesMap $ M.insertWith (<>) i rws m-- instance S.Store AutoRewrite instance S.Store AxiomEnv instance S.Store Rewrite instance S.Store Equation-instance S.Store DefinedFuns+instance S.Store SMTSolver+instance S.Store Eliminate instance NFData AutoRewrite instance NFData AxiomEnv instance NFData Rewrite instance NFData Equation-instance NFData DefinedFuns+instance NFData SMTSolver+instance NFData Eliminate  dedupAutoRewrites :: M.HashMap SubcId [AutoRewrite] -> [AutoRewrite] dedupAutoRewrites = Set.toList . Set.unions . map Set.fromList . M.elems@@ -997,10 +930,10 @@ instance Semigroup AxiomEnv where   a1 <> a2        = AEnv aenvEqs' aenvSimpl' aenvExpand' aenvAutoRW'     where-      aenvEqs'    = aenvEqs a1    <> aenvEqs a2-      aenvSimpl'  = aenvSimpl a1  <> aenvSimpl a2-      aenvExpand' = aenvExpand a1 <> aenvExpand a2-      aenvAutoRW' = aenvAutoRW a1 <> aenvAutoRW a2+      aenvEqs'    = (aenvEqs a1)    <> (aenvEqs a2)+      aenvSimpl'  = (aenvSimpl a1)  <> (aenvSimpl a2)+      aenvExpand' = (aenvExpand a1) <> (aenvExpand a2)+      aenvAutoRW' = (aenvAutoRW a1) <> (aenvAutoRW a2)  instance Monoid AxiomEnv where   mempty          = AEnv [] [] (M.fromList []) (M.fromList [])@@ -1009,32 +942,14 @@ instance PPrint AxiomEnv where   pprintTidy _ = text . show --newtype DefinedFuns = MkDefinedFuns [Equation]-  deriving (Data, Eq, Ord, Show, Generic)--instance Semigroup DefinedFuns where-  MkDefinedFuns eq1 <> MkDefinedFuns eq2 = MkDefinedFuns (eq1 <> eq2)--instance Monoid DefinedFuns where-  mempty = MkDefinedFuns []--instance PPrint DefinedFuns where-  pprintTidy k (MkDefinedFuns eqs) = pprintTidy k eqs--type Equation = EquationV Symbol-data EquationV v = Equ+data Equation = Equ   { eqName :: !Symbol           -- ^ name of reflected function   , eqArgs :: [(Symbol, Sort)]  -- ^ names of parameters-  , eqBody :: !(ExprV v)        -- ^ definition of body+  , eqBody :: !Expr             -- ^ definition of body   , eqSort :: !Sort             -- ^ sort of body   , eqRec  :: !Bool             -- ^ is this a recursive definition   }-  deriving (Data, Eq, Ord, Show, Generic, Functor)--eqnToHornSMT :: Doc -> Equation -> Doc-eqnToHornSMT keyword (Equ f xs e s _) = parens (keyword <+> pprint f <+> toHornSMT xs <+> toHornSMT s <+> toHornSMT e)-+  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)@@ -1061,33 +976,34 @@   , arRHS  :: Expr } deriving (Eq, Ord, Show, Generic) +instance Hashable SortedReft instance Hashable AutoRewrite -autoRWToFix :: M.HashMap SubcId [AutoRewrite] -> Doc-autoRWToFix autoRW =-  vcat $-  map fixRW rewrites ++-  rwsMapping-  where-    rewrites = dedupAutoRewrites autoRW -    fixRW rw@(AutoRewrite args lhs rhs) =-        text ("autorewrite " ++ show (hash rw))-        <+> hsep (map toFix args)-        <+> text "="-        <+> text "{"-        <+> toFix lhs-        <+> text "="-        <+> toFix rhs-        <+> text "}"+instance Fixpoint (M.HashMap SubcId [AutoRewrite]) where+  toFix autoRW =+    vcat $+    map fixRW rewrites +++    rwsMapping+    where+      rewrites = dedupAutoRewrites autoRW -    rwsMapping = do-      (cid, rws) <- M.toList autoRW-      rw         <-  rws-      return $ "rewrite" <+> brackets (text $ show cid ++ " : " ++ show (hash rw))+      fixRW rw@(AutoRewrite args lhs rhs) =+          text ("autorewrite " ++ show (hash rw))+          <+> hsep (map toFix args)+          <+> text "{"+          <+> toFix lhs+          <+> text "="+          <+> toFix rhs+          <+> text "}" +      rwsMapping = do+        (cid, rws) <- M.toList autoRW+        rw         <-  rws+        return $ "rewrite" <+> brackets (text $ show cid ++ " : " ++ show (hash rw))  + -- eg  SMeasure (f D [x1..xn] e) -- for f (D x1 .. xn) = e data Rewrite  = SMeasure@@ -1098,36 +1014,28 @@   }   deriving (Data, Eq, Ord, Show, Generic) -instance ToHornSMT Rewrite where-  toHornSMT (SMeasure f d xs e) =  parens ("match" <+> toHornSMT f <+> toHornSMT (d:xs) <+> toHornSMT e)--- instance Fixpoint AxiomEnv where   toFix axe = vcat ((toFix <$> L.sort (aenvEqs axe)) ++ (toFix <$> L.sort (aenvSimpl axe)))               $+$ renderExpand (pairdoc <$> L.sort (M.toList $ aenvExpand axe))-              $+$ autoRWToFix (aenvAutoRW 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 s _) = "define" <+> toFix f <+> ppArgs xs <+> ":" <+> toFix s <+> text "=" <+> braces (parens (toFix e)) -instance Fixpoint LocalRewritesEnv where-  toFix (LocalRewritesMap rws) = vcat $ uncurry toFixLocal <$> M.toList rws-    where-      toFixLocal bid (LocalRewrites rws) = text "defineLocal" <+> toFix bid-        <+> brackets (vcat $ punctuate ";" $ uncurry toFixRewrite <$> M.toList rws)-      toFixRewrite sym eq = toFix sym <+> text ":=" <+> toFix eq- instance Fixpoint Rewrite where   toFix (SMeasure f d xs e)     = text "match"    <+> toFix f    <+> toFix d <+> hsep (toFix <$> xs)-   <+> braces (toFix e)+   <+> text " = "+   <+> parens (toFix e)  instance PPrint Rewrite where   pprintTidy _ = toFix
src/Language/Fixpoint/Types/Environments.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-}@@ -14,10 +16,7 @@ module Language.Fixpoint.Types.Environments (    -- * Environments-    SEnv-  , SEnvB(..)-  , SESearch-  , SESearchB(..)+    SEnv, SESearch(..)   , emptySEnv, toListSEnv, fromListSEnv, fromMapSEnv   , mapSEnvWithKey, mapSEnv, mapMSEnv   , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv, unionSEnv, unionSEnv'@@ -46,13 +45,11 @@   , BindEnv, beBinds   , emptyBindEnv   , fromListBindEnv-  , insertBindEnv, lookupBindEnv, bindEnvSize+  , insertBindEnv, lookupBindEnv   , filterBindEnv, mapBindEnv, mapWithKeyMBindEnv, adjustBindEnv   , bindEnvFromList, bindEnvToList, deleteBindEnv, elemsBindEnv   , EBindEnv, splitByQuantifiers -  , coerceBindEnv-   -- * Information needed to lookup and update Solutions   -- , SolEnv (..) @@ -66,9 +63,12 @@ import qualified Data.Store as S import qualified Data.List   as L import           Data.Generics             (Data)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif+ import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic)-import           Data.Hashable             (Hashable) import qualified Data.HashMap.Strict       as M import qualified Data.HashSet              as S import           Data.Maybe@@ -76,11 +76,8 @@ import           Text.PrettyPrint.HughesPJ.Compat import           Control.DeepSeq -import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Types.Binders import           Language.Fixpoint.Types.Names-import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Types.Refinements import           Language.Fixpoint.Types.Substitutions () import           Language.Fixpoint.Misc@@ -93,9 +90,8 @@ instance PPrint IBindEnv where   pprintTidy _ = pprint . L.sort . elemsIBindEnv -type SEnv a = SEnvB Symbol a-newtype SEnvB b a = SE { seBinds :: M.HashMap b a }-                    deriving (Eq, Data, Typeable, Generic, Foldable, Traversable)+newtype SEnv a     = SE { seBinds :: M.HashMap Symbol a }+                     deriving (Eq, Data, Typeable, Generic, Foldable, Traversable)  data SizedEnv a    = BE { _beSize  :: !Int                         , beBinds :: !(BindMap a)@@ -105,86 +101,85 @@   pprintTidy k (BE _ m) = pprintTidy k m  -- Invariant: All BindIds in the map are less than beSize-type BindEnv a     = SizedEnv (Symbol, SortedReft, a)-newtype EBindEnv a = EB (BindEnv a)+type BindEnv       = SizedEnv (Symbol, SortedReft)+newtype EBindEnv   = EB BindEnv -splitByQuantifiers :: BindEnv a -> [BindId] -> (BindEnv a, EBindEnv a)-splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> notElem k ebs) bs+splitByQuantifiers :: BindEnv -> [BindId] -> (BindEnv, EBindEnv)+splitByQuantifiers (BE i bs) ebs = ( BE i $ M.filterWithKey (\k _ -> not (elem k ebs)) bs                                    , EB $ BE i $ M.filterWithKey (\k _ -> elem k ebs) bs                                    ) --- data SolEnv        = SolEnv { soeBinds :: !BindEnv }+-- data SolEnv        = SolEnv { soeBinds :: !BindEnv }  --                     deriving (Eq, Show, Generic) -instance (Ord b, PPrint b, PPrint a) => PPrint (SEnvB b a) where+instance PPrint a => PPrint (SEnv a) where   pprintTidy k = pprintKVs k . L.sortBy (compare `on` fst) . toListSEnv  {-# SCC toListSEnv #-}-toListSEnv              ::  SEnvB b a -> [(b, a)]+toListSEnv              ::  SEnv a -> [(Symbol, a)] toListSEnv (SE env)     = M.toList env -fromListSEnv            ::  Hashable b => [(b, a)] -> SEnvB b a+fromListSEnv            ::  [(Symbol, a)] -> SEnv a fromListSEnv            = SE . M.fromList -fromMapSEnv             ::  M.HashMap b a -> SEnvB b a+fromMapSEnv             ::  M.HashMap Symbol a -> SEnv a fromMapSEnv             = SE -mapSEnv                 :: (a₁ -> a₂) -> SEnvB b a₁ -> SEnvB b a₂+mapSEnv                 :: (a -> b) -> SEnv a -> SEnv b mapSEnv f (SE env)      = SE (fmap f env) -mapMSEnv                :: (Monad m, Hashable b) => (a₁ -> m a₂) -> SEnvB b a₁ -> m (SEnvB b a₂)+mapMSEnv                :: (Monad m) => (a -> m b) -> SEnv a -> m (SEnv b) mapMSEnv f env          = fromListSEnv <$> mapM (secondM f) (toListSEnv env) -mapSEnvWithKey          :: Hashable b => ((b, a₁) -> (b, a₂)) -> SEnvB b a₁ -> SEnvB b a₂+mapSEnvWithKey          :: ((Symbol, a) -> (Symbol, b)) -> SEnv a -> SEnv b mapSEnvWithKey f        = fromListSEnv . fmap f . toListSEnv -deleteSEnv :: Hashable b => b -> SEnvB b a -> SEnvB b a+deleteSEnv :: Symbol -> SEnv a -> SEnv a deleteSEnv x (SE env)   = SE (M.delete x env) -insertSEnv :: Hashable b => b -> a -> SEnvB b a -> SEnvB b a+insertSEnv :: Symbol -> a -> SEnv a -> SEnv a insertSEnv x v (SE env) = SE (M.insert x v env)  {-# SCC lookupSEnv #-}-lookupSEnv :: Hashable b => b -> SEnvB b a -> Maybe a+lookupSEnv :: Symbol -> SEnv a -> Maybe a lookupSEnv x (SE env)   = M.lookup x env -emptySEnv :: SEnvB b a+emptySEnv :: SEnv a emptySEnv               = SE M.empty -memberSEnv :: Hashable b => b -> SEnvB b a -> Bool+memberSEnv :: Symbol -> SEnv a -> Bool memberSEnv x (SE env)   = M.member x env -intersectWithSEnv :: Eq b => (a₁ -> a₂ -> a) -> SEnvB b a₁ -> SEnvB b a₂ -> SEnvB b a+intersectWithSEnv :: (v1 -> v2 -> a) -> SEnv v1 -> SEnv v2 -> SEnv a intersectWithSEnv f (SE m1) (SE m2) = SE (M.intersectionWith f m1 m2) -differenceSEnv :: Hashable b => SEnvB b a -> SEnvB b w -> SEnvB b a+differenceSEnv :: SEnv a -> SEnv w -> SEnv a differenceSEnv (SE m1) (SE m2) = SE (M.difference m1 m2) -filterSEnv :: (a -> Bool) -> SEnvB b a -> SEnvB b a+filterSEnv :: (a -> Bool) -> SEnv a -> SEnv a filterSEnv f (SE m)     = SE (M.filter f m) -unionSEnv :: Eq b => SEnvB b a -> M.HashMap b a -> SEnvB b a+unionSEnv :: SEnv a -> M.HashMap Symbol a -> SEnv a unionSEnv (SE m1) m2    = SE (M.union m1 m2) -unionSEnv' :: Eq b => SEnvB b a -> SEnvB b a -> SEnvB b a+unionSEnv' :: SEnv a -> SEnv a -> SEnv a unionSEnv' (SE m1) (SE m2)    = SE (M.union m1 m2)  {-# SCC lookupSEnvWithDistance #-}-lookupSEnvWithDistance :: Binder b => b -> SEnvB b a -> SESearchB b a+lookupSEnvWithDistance :: Symbol -> SEnv a -> SESearch a lookupSEnvWithDistance x (SE env)   = case M.lookup x env of      Just z  -> Found z-     Nothing -> Alts alts+     Nothing -> Alts $ symbol <$> alts   where-    alts       = takeMin $ zip (editDistance x <$> ss) ss-    ss         = fst <$> M.toList env+    alts       = takeMin $ zip (editDistance x' <$> ss) ss+    ss         = symbolString <$> fst <$> M.toList env+    x'         = symbolString x     takeMin xs = [z | (d, z) <- xs, d == getMin xs]     getMin     = minimum . (fst <$>)  -type SESearch a = SESearchB Symbol a-data SESearchB b a = Found a | Alts [b]-  deriving Show+data SESearch a = Found a | Alts [Symbol]  -- | Functions for Indexed Bind Environment @@ -214,49 +209,41 @@ fromListIBindEnv = FB . S.fromList  -- | Functions for Global Binder Environment-insertBindEnv :: Symbol -> SortedReft -> a -> BindEnv a -> (BindId, BindEnv a)-insertBindEnv x r a (BE n m) = (n, BE (n + 1) (M.insert n (x, r, a) m))--bindEnvSize :: BindEnv a -> Int-bindEnvSize (BE n _) = n+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, a))] -> BindEnv a+fromListBindEnv :: [(BindId, (Symbol, SortedReft))] -> BindEnv fromListBindEnv xs = BE (length xs) (M.fromList xs) -emptyBindEnv :: BindEnv a+emptyBindEnv :: BindEnv emptyBindEnv = BE 0 M.empty -filterBindEnv   :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv a -> BindEnv a-filterBindEnv f (BE n be) = BE n (M.filterWithKey (\ n' (x, r, _) -> f n' x r) be)+filterBindEnv   :: (BindId -> Symbol -> SortedReft -> Bool) -> BindEnv -> BindEnv+filterBindEnv f (BE n be) = BE n (M.filterWithKey (\ n (x, r) -> f n x r) be) -bindEnvFromList :: [(BindId, (Symbol, SortedReft, a))] -> BindEnv a+bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv bindEnvFromList [] = emptyBindEnv bindEnvFromList bs = BE (1 + maxId) be   where-    maxId          = maximum [ n | (n,(_,_,_)) <- bs ]-    be             = M.fromList bs--elemsBindEnv :: BindEnv a -> [BindId]-elemsBindEnv be = fst <$> bindEnvToList be+    maxId          = maximum $ fst3 <$> bs+    be             = M.fromList [(n, (x, r)) | (n, x, r) <- bs] -bindEnvToList :: BindEnv a -> [(BindId, (Symbol, SortedReft, a))]-bindEnvToList (BE _ be) = M.toList be+elemsBindEnv :: BindEnv -> [BindId]+elemsBindEnv be = fst3 <$> bindEnvToList be -mapBindEnv :: (BindId -> (Symbol, SortedReft, a) -> (Symbol, SortedReft, a)) -> BindEnv a -> BindEnv a-mapBindEnv f (BE n m) = BE n (M.mapWithKey f m)-  -- where-    -- f' k (x, y, a) = let (x', y') = f k (x, y) in (x', y', a)+bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)]+bindEnvToList (BE _ be) = [(n, x, r) | (n, (x, r)) <- M.toList be] +mapBindEnv :: (BindId -> (Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv+mapBindEnv f (BE n m) = BE n $ M.mapWithKey f m -- (\i z -> tracepp (msg i z) $ f z) m --  where --    msg i z = "beMap " ++ show i ++ " " ++ show z -mapWithKeyMBindEnv :: (Monad m) => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv a -> m (BindEnv a)-mapWithKeyMBindEnv f (BE n m) = BE n . M.fromList <$> mapM f' (M.toList m)-  where-    f' (k, (x, y, a)) = do { (k', (x', y')) <- f (k, (x, y)) ; return (k', (x', y', a)) }+mapWithKeyMBindEnv :: (Monad m) => ((BindId, (Symbol, SortedReft)) -> m (BindId, (Symbol, SortedReft))) -> BindEnv -> m BindEnv+mapWithKeyMBindEnv f (BE n m) = (BE n . M.fromList) <$> mapM f (M.toList m) -lookupBindEnv :: BindId -> BindEnv a -> (Symbol, SortedReft, a)+lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft) lookupBindEnv k (BE _ m) = fromMaybe err (M.lookup k m)   where     err                  = errorstar $ "lookupBindEnv: cannot find binder" ++ show k@@ -279,27 +266,24 @@ diffIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv diffIBindEnv (FB m1) (FB m2) = FB $ m1 `S.difference` m2 -adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv a -> BindEnv a-adjustBindEnv f i (BE n m) = BE n (M.adjust f' i m)-  where-    f'  (x, y, a) = let (x', y') = f (x, y) in (x', y', a)-+adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv+adjustBindEnv f i (BE n m) = BE n $ M.adjust f i m -deleteBindEnv :: BindId -> BindEnv a -> BindEnv a+deleteBindEnv :: BindId -> BindEnv -> BindEnv deleteBindEnv i (BE n m) = BE n $ M.delete i m -instance Functor (SEnvB b) where+instance Functor SEnv where   fmap = mapSEnv -instance Fixpoint (EBindEnv a) where+instance Fixpoint EBindEnv where   toFix (EB (BE _ m)) = vcat $ map toFixBind $ hashMapToAscList m     where-      toFixBind (i, (x, r, _)) = "ebind" <+> toFix i <+> toFix x <+> ": { " <+> toFix (sr_sort r) <+> " }"+      toFixBind (i, (x, r)) = "ebind" <+> toFix i <+> toFix x <+> ": { " <+> toFix (sr_sort r) <+> " }" -instance Fixpoint (BindEnv a) where+instance Fixpoint BindEnv where   toFix (BE _ m) = vcat $ map toFixBind $ hashMapToAscList m     where-      toFixBind (i, (x, r, _)) = "bind" <+> toFix i <+> toFix x <+> ":" <+> toFix r+      toFixBind (i, (x, r)) = "bind" <+> toFix i <+> toFix x <+> ":" <+> toFix r  instance (Fixpoint a) => Fixpoint (SEnv a) where    toFix (SE m)   = toFix (hashMapToAscList m)@@ -307,37 +291,37 @@ instance Fixpoint (SEnv a) => Show (SEnv a) where   show = render . toFix -instance Eq b => Semigroup (SEnvB b a) where+instance Semigroup (SEnv a) where   s1 <> s2 = SE $ M.union (seBinds s1) (seBinds s2) -instance Eq b => Monoid (SEnvB b a) where+instance Monoid (SEnv a) where   mempty        = SE M.empty -instance Semigroup (BindEnv a) where+instance Semigroup BindEnv where   (BE 0 _) <> b        = b   b        <> (BE 0 _) = b   _        <> _        = errorstar "mappend on non-trivial BindEnvs" -instance Monoid (BindEnv a) where+instance Monoid BindEnv where   mempty  = BE 0 M.empty   mappend = (<>) -envCs :: BindEnv a -> IBindEnv -> [(Symbol, SortedReft)]-envCs be (FB s) = [(x, y) | (x, y, _) <- M.elems (M.intersection (beBinds be) (S.toMap s))]+envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)]+envCs be env = [lookupBindEnv i be | i <- elemsIBindEnv env] -instance Fixpoint IBindEnv where+instance Fixpoint (IBindEnv) where   toFix (FB ids) = text "env" <+> toFix ids  --------------------------------------------------------------------------------  instance NFData Packs instance NFData IBindEnv-instance NFData a => NFData (BindEnv a)+instance NFData BindEnv instance (NFData a) => NFData (SEnv a)  instance S.Store Packs instance S.Store IBindEnv-instance (S.Store a) => S.Store (BindEnv a)+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@@ -351,7 +335,7 @@                deriving (Eq, Show, Generic)  instance Fixpoint Packs where-  toFix (Packs m) = vcat $ ("pack" <+>) . toFix <$> kIs+  toFix (Packs m) = vcat $ (("pack" <+>) . toFix) <$> kIs     where       kIs = L.sortBy (compare `on` snd) . M.toList $ m @@ -373,9 +357,3 @@   where     kIs       = [ (k, i) | (i, ks) <- kPacks, k <- ks ]     kPacks    = zip [0..] . coalesce . fmap S.toList $ kvss--coerceBindEnv :: ElabFlags -> BindEnv a -> BindEnv a-coerceBindEnv ef be = be { beBinds = M.map (\(s, sr, a) ->-                                                let srs = coerceMapToArray (sr_sort sr) in-                                                (s, sr { sr_sort = if elabSetBag ef then coerceSetBagToArray srs else srs } , a))-                                            (beBinds be) }
src/Language/Fixpoint/Types/Errors.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP                       #-} {-# LANGUAGE DeriveDataTypeable        #-} {-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE DeriveFoldable            #-} {-# LANGUAGE DeriveTraversable         #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -9,7 +10,7 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE ViewPatterns              #-} -{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Fixpoint.Types.Errors (   -- * Concrete Location Type@@ -58,11 +59,14 @@ import           Data.Aeson                    hiding (Error, Result) import           Data.Generics                 (Data) import           Data.Typeable+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup                (Semigroup (..))+#endif+ import           Control.DeepSeq -- import           Data.Hashable import qualified Data.Store                   as S import           GHC.Generics                  (Generic)-import           GHC.Stack                     (HasCallStack) import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Spans import           Language.Fixpoint.Misc@@ -98,7 +102,7 @@   errs :: Error -> [Error1]-errs (Error es) = es+errs (Error es) = es   data Error1 = Error1   { errLoc :: SrcSpan@@ -119,7 +123,7 @@   toFix = pprint  instance Exception Error--- instance Exception (FixResult Error)+instance Exception (FixResult Error)   ---------------------------------------------------------------------@@ -138,7 +142,7 @@ err sp d = Error [Error1 sp d]  ----------------------------------------------------------------------panic :: HasCallStack => String -> a+panic :: String -> a --------------------------------------------------------------------- panic = die . err dummySpan . text . (panicMsg ++) @@ -146,7 +150,7 @@ panicMsg = "PANIC: Please file an issue at https://github.com/ucsd-progsys/liquid-fixpoint \n"  ----------------------------------------------------------------------die :: HasCallStack => Error -> a+die :: Error -> a --------------------------------------------------------------------- die = throw @@ -168,20 +172,19 @@ -- | Result --------------------------------------------------------- --------------------------------------------------------------------- -data FixResult a-  = Crash [(a, Maybe String)] String-  | Unsafe Solver.Stats ![a]-  | Safe Solver.Stats+data FixResult a = Crash [a] String+                 | Safe Solver.Stats                  -- ^ The 'Solver' statistics, which include also the constraints /actually/                  -- checked. A program will be \"trivially safe\" in case this                  -- number is 0.-  deriving (Data, Typeable, Foldable, Functor, Traversable, Show, Generic)+                 | Unsafe Solver.Stats ![a]+                   deriving (Data, Typeable, Foldable, Traversable, Show, Generic)  instance (NFData a) => NFData (FixResult a)  instance Eq a => Eq (FixResult a) where   Crash xs _   == Crash ys _         = xs == ys-  Unsafe s1 xs == Unsafe s2 ys       = xs == ys && s1 == s2+  Unsafe s1 xs == Unsafe s2 ys       = xs == ys && s1 == s2    Safe s1      == Safe s2            = s1 == s2   _            == _                  = False @@ -189,27 +192,38 @@   Safe s1        <> Safe s2        = Safe (s1 <> s2)   Safe _         <> x              = x   x              <> Safe _         = x-  _              <> c@Crash{}      = c-  c@Crash{}      <> _              = c+  _              <> c@(Crash{})    = c+  c@(Crash{})    <> _              = c   (Unsafe s1 xs) <> (Unsafe s2 ys) = Unsafe (s1 <> s2) (xs ++ ys)  instance Monoid (FixResult a) where   mempty  = Safe mempty   mappend = (<>) --- instance Functor FixResult where---   fmap f (Crash xs msg)   = Crash (f <$> xs) msg---   fmap f (Unsafe s xs)    = Unsafe s (f <$> xs)---   fmap _ (Safe stats)     = Safe stats+instance Functor FixResult where+  fmap f (Crash xs msg)   = Crash (f <$> xs) msg+  fmap f (Unsafe s xs)    = Unsafe s (f <$> xs)+  fmap _ (Safe stats)     = Safe stats +-- instance (ToJSON a) => ToJSON (FixResult a) where+--   toJSON (Safe _ )      = object [ "result"  .= String "safe"   ]++--   toJSON (Unsafe _ ts)  = object [ "result"  .= String "unsafe" +--                                  , "tags"    .= toJSON ts+--                                  ]+--   toJSON (Crash ts msg) = object [ "result"  .= String "crash"+--                                  , "message" .= msg +--                                  , "tags"    .= toJSON ts+--                                  ]+ instance (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 . fst <$> xs)-resultDoc (Unsafe _ xs)    = vcat $ text "Unsafe:"           : (("WARNING:" <+>) . toFix <$> xs)+resultDoc (Safe stats)     = text "Safe (" <+> text (show $ Solver.checked stats) <+> " constraints checked)" +resultDoc (Crash xs msg)   = vcat $ text ("Crash!: " ++ msg) : ((("CRASH:" <+>) . toFix) <$> xs)+resultDoc (Unsafe _ xs)    = vcat $ text "Unsafe:"           : ((("WARNING:" <+>) . toFix) <$> xs)  instance (Fixpoint a) => PPrint (FixResult a) where   pprintTidy _ = resultDoc
+ src/Language/Fixpoint/Types/Graduals.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE TupleSections              #-}++-- | This module contains the top-level SOLUTION data types,+--   including various indices used for solving.++module Language.Fixpoint.Types.Graduals (+  uniquify,++  makeSolutions,++  GSol,++  Gradual (..)+  ) where++import Language.Fixpoint.Types.Refinements+import Language.Fixpoint.Types.Constraints+import Language.Fixpoint.Types.Config+import Language.Fixpoint.Types.PrettyPrint+import Language.Fixpoint.Types.Environments+import Language.Fixpoint.Types.Substitutions+import Language.Fixpoint.Types.Visitor+import Language.Fixpoint.Types.Spans+import Language.Fixpoint.Types.Theories+import Language.Fixpoint.Types.Names        (gradIntSymbol, tidySymbol)+import Language.Fixpoint.Misc               (allCombinations, errorstar)++import Control.DeepSeq++import qualified Data.HashMap.Strict       as M+import qualified Data.List                 as L++import Control.Monad.State.Lazy+import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base(4,14,0)+import Data.Semigroup (Semigroup (..))+#endif++import qualified Language.Fixpoint.SortCheck       as So+import Language.Fixpoint.Solver.Sanitize (symbolEnv)+++data GSol = GSol !SymEnv !(M.HashMap KVar (Expr, GradInfo))++instance Semigroup GSol where+  (GSol e1 m1) <> (GSol e2 m2) = GSol (e1 <> e2) (m1 <> m2)++instance Monoid GSol where+  mempty = GSol mempty mempty++instance Show GSol where+  show (GSol _ m) = "GSOL = \n" ++ unlines ((\(k,(e, i)) -> showpp k ++ showInfo i ++  " |-> " ++ showpp (tx e)) <$> M.toList m)+    where+      tx e = subst (mkSubst $ [(x, EVar $ tidySymbol x) | x <- syms e]) e+      showInfo i = show i+++makeSolutions :: (NFData a, Fixpoint a, Show a)+              => Config -> SInfo a+              -> [(KVar, (GWInfo, [[Expr]]))]+              -> Maybe [GSol]++makeSolutions _ _ []+  = Nothing+makeSolutions cfg fi kes+  = Just $ map (GSol env . M.fromList) (allCombinations (go  <$> kes))+  where+    go (k, (i, es)) = [(k, (pAnd (gexpr i:e'), ginfo i)) | e' <- es]+    env = symbolEnv cfg fi+++-------------------------------------------------------------------------------+-- |  Make each gradual appearence unique -------------------------------------+-------------------------------------------------------------------------------+uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> (SInfo a)++uniquify fi = fi{cm = cm', ws = ws', bs = bs'}+  where+  (cm', km, bs') = uniquifyCS (bs fi) (cm fi)+  ws'            = expandWF km (ws fi)++uniquifyCS :: (NFData a, Fixpoint a, Loc a)+           => BindEnv+           -> M.HashMap SubcId (SimpC a)+           -> (M.HashMap SubcId (SimpC a), M.HashMap KVar [(KVar, Maybe SrcSpan)], BindEnv)+uniquifyCS bs cs+  = (x, km, benv st)+--   = (x, km, mapBindEnv (\i (x,r) -> if i `elem` ubs st then (x, ungrad r) else (x, r)) $ benv st)+  where+    (x, st) = runState (uniq cs) (initUniqueST bs)+    km      = kmap st+    -- gs      = [x | xs <- M.elems km, (x,_) <- xs]+++class Unique a where+   uniq :: a -> UniqueM a++instance Unique a => Unique (M.HashMap SubcId a) where+  uniq m = M.fromList <$> mapM (\(i,x) -> (i,) <$> uniq x) (M.toList m)++instance Loc a => Unique (SimpC a) where+  uniq cs = do+    updateLoc $ srcSpan $ _cinfo cs+    rhs <- uniq (_crhs cs)+    env <- uniq (_cenv cs)+    return cs{_crhs = rhs, _cenv = env}++instance Unique IBindEnv where+  uniq env = withCache (fromListIBindEnv <$> mapM uniq (elemsIBindEnv env))++instance Unique BindId where+  uniq i = do+    bs <- benv <$> get+    let (x, t) = lookupBindEnv i bs+    resetChange+    t' <- uniq t+    hasChanged <- change <$> get+    if hasChanged+      then do let (i', bs') = insertBindEnv x t' bs+              updateBEnv i bs'+              return i'+      else return i++instance Unique SortedReft where+  uniq (RR s r) = RR s <$> uniq r++instance Unique Reft where+  uniq (Reft (x,e)) = (Reft . (x,)) <$> uniq e++instance Unique Expr where+  uniq = mapMExpr go+   where+    go (PGrad k su i e) = do+      k'  <- freshK k+      src <- uloc <$> get+      return $ PGrad k' su (i{gused = src}) e+    go e              = return e++-------------------------------------------------------------------------------+-- | The Unique Monad ---------------------------------------------------------+-------------------------------------------------------------------------------++type UniqueM = State UniqueST+data UniqueST+  = UniqueST { freshId :: Integer+             , kmap    :: M.HashMap KVar [(KVar, Maybe SrcSpan)]+             , change  :: Bool+             , cache   :: M.HashMap KVar KVar+             , uloc    :: Maybe SrcSpan+             , ubs     :: [BindId]+             , benv    :: BindEnv+             }++updateLoc :: SrcSpan -> UniqueM ()+updateLoc x = modify $ \s -> s{uloc = Just x}++withCache :: UniqueM a -> UniqueM a+withCache act = do+  emptyCache+  a <- act+  emptyCache+  return a++emptyCache :: UniqueM ()+emptyCache = modify $ \s -> s{cache = mempty}++addCache :: KVar -> KVar -> UniqueM ()+addCache k k' = modify $ \s -> s{cache = M.insert k k' (cache s)}++updateBEnv :: BindId -> BindEnv -> UniqueM ()+updateBEnv i bs = modify $ \s -> s{benv = bs, ubs = i:(ubs s)}++setChange :: UniqueM ()+setChange = modify $ \s -> s{change = True}++resetChange :: UniqueM ()+resetChange = modify $ \s -> s{change = False}++initUniqueST :: BindEnv ->  UniqueST+initUniqueST = UniqueST 0 mempty False mempty Nothing mempty++freshK, freshK' :: KVar -> UniqueM KVar+freshK k  = do+  setChange+  cached <- cache <$> get+  case M.lookup k cached of+    {- OPTIMIZATION: Only create one fresh occurence of ? per constraint environment. -}+    Just k' -> return  k'+    Nothing -> freshK' k++freshK' k = do+  i <- freshId <$> get+  modify $ (\s -> s{freshId = i + 1})+  let k' = KV $ gradIntSymbol i+  addK k k'+  addCache k k'+  return k'++addK :: KVar -> KVar -> UniqueM ()+addK key val =+  modify $ (\s -> s{kmap = M.insertWith (++) key [(val, uloc s)] (kmap s)})++-------------------------------------------------------------------------------+-- | expandWF -----------------------------------------------------------------+-------------------------------------------------------------------------------++expandWF :: (NFData a, Fixpoint a)+         => M.HashMap KVar [(KVar, Maybe SrcSpan)]+         -> M.HashMap KVar (WfC a)+         -> M.HashMap KVar (WfC a)+expandWF km ws+  = M.fromList $+       ([(k, updateKVar k src w) | (i, w) <- gws, (kw, ks) <- km', kw == i, (k, src) <- ks]+        ++ kws)+  where+    (gws, kws)       = L.partition (isGWfc . snd) $ M.toList ws+    km'              = M.toList km+    updateKVar k src wfc = wfc { wrft = (\(v,s,_) -> (v,s,k)) $ wrft wfc+                               , wloc = (wloc wfc){gused = src}+                               }++-------------------------------------------------------------------------------+-- |  Substitute Gradual Solution ---------------------------------------------+-------------------------------------------------------------------------------++class Gradual a where+  gsubst :: GSol -> a -> a++instance Gradual Expr where+  gsubst (GSol env m) e   = mapGVars' (\(k, _) -> Just (fromMaybe (err k) (mknew k))) e+    where+      mknew k = So.elaborate "initBGind.mkPred" env $ fst <$> M.lookup k m+      err   k = errorstar ("gradual substitution: Cannot find " ++ showpp k)++instance Gradual Reft where+  gsubst su (Reft (x, e)) = Reft (x, gsubst su e)++instance Gradual SortedReft where+  gsubst su r = r {sr_reft = gsubst su (sr_reft r)}++instance Gradual (SimpC a) where+  gsubst su c = c {_crhs = gsubst su (_crhs c)}++instance Gradual BindEnv where+  gsubst su = mapBindEnv (\_ (x, r) -> (x, gsubst su r))++instance Gradual v => Gradual (M.HashMap k v) where+  gsubst su = M.map (gsubst su)++instance Gradual (SInfo a) where+  gsubst su fi = fi { bs = gsubst su (bs fi)+                    , cm = gsubst su (cm fi)+                    }
src/Language/Fixpoint/Types/Names.hs view
@@ -5,11 +5,12 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE PatternGuards              #-} -{-# OPTIONS_GHC -Wno-orphans            #-}  -- | This module contains Haskell variables representing globally visible names. --   Rather than have strings floating around the system, all constant names@@ -42,13 +43,12 @@   -- , isCtorSymbol   , isNontrivialVV   , isDummy-  , isFixKey    -- * Destructors   , prefixOfSym   , suffixOfSym   , stripPrefix-  , stripSuffix+  , stripSuffix    , consSym   , unconsSym   , dropSym@@ -60,7 +60,6 @@   , nonSymbol   , vvCon   , tidySymbol-  , unKArgSymbol    -- * Widely used prefixes   , anfPrefix@@ -72,19 +71,18 @@   , dummySymbol   , intSymbol   , tempSymbol+  , gradIntSymbol   , appendSymbolText-  , hvarArgSymbol    -- * Wrapping Symbols   , litSymbol   , bindSymbol   , testSymbol   , renameSymbol-  , renameSubstSymbol   , kArgSymbol   , existSymbol   , suffixSymbol-  , mappendSym+  , mappendSym     -- * Unwrapping Symbols   , unLitSymbol@@ -93,26 +91,23 @@   , dummyName   , preludeName   , boolConName-  , boolLConName   , funConName   , listConName   , listLConName+  , tupConName   , setConName   , mapConName-  , bagConName-  , arrayConName-  , ffldConName   , strConName   , charConName   , nilName   , consName   , vvName-  , sizeName+  , size32Name+  , size64Name   , bitVecName-  , intbv32Name, intbv64Name, bv32intName, bv64intName-  , intbv8Name, intbv16Name, bv8intName, bv16intName+  , bvAndName+  , bvOrName   , propConName-   -- HKT , tyAppName   , isPrim   , prims@@ -120,22 +115,24 @@   , divFuncName    -- * Casting function names-  , setToIntName, bitVecToIntName, mapToIntName, bagToIntName, boolToIntName, realToIntName, toIntName, tyCastName+  , setToIntName, bitVecToIntName, mapToIntName, boolToIntName, realToIntName, toIntName, tyCastName   , setApplyName, bitVecApplyName, mapApplyName, boolApplyName, realApplyName, intApplyName   , applyName   , coerceName    , lambdaName   , lamArgSymbol-  , isLamArgSymbol, etaExpSymbol+  , isLamArgSymbol  ) where  import           Control.DeepSeq             (NFData (..)) import           Control.Arrow               (second)-import           Data.ByteString.Builder     (Builder) import           Data.Char                   (ord) import           Data.Maybe                  (fromMaybe)+#if !MIN_VERSION_base(4,14,0)+import           Data.Monoid                 ((<>))+#endif import           Data.Generics               (Data) import           Data.Hashable               (Hashable (..)) import qualified Data.HashSet                as S hiding (size)@@ -148,15 +145,11 @@ import qualified GHC.Arr                     as Arr import           GHC.Generics                (Generic) import           Text.PrettyPrint.HughesPJ   (text)-import           Language.Fixpoint.Misc-import           Language.Fixpoint.Types.Binders import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Spans-import           Language.Fixpoint.Utils.Builder as Builder (fromText)+import           Language.Fixpoint.Utils.Builder as Builder (Builder, fromText) import Data.Functor.Contravariant (Contravariant(contramap)) import qualified Data.Binary as B-import qualified Data.Aeson       as Aeson-import qualified Data.Aeson.Types as Aeson  --------------------------------------------------------------- -- | Symbols --------------------------------------------------@@ -183,8 +176,7 @@   = S { _symbolId      :: !Id       , symbolRaw      :: T.Text       , symbolEncoded  :: T.Text-      }-    deriving (Data, Typeable, Generic)+      } deriving (Data, Typeable, Generic)  instance Eq Symbol where   S i _ _ == S j _ _ = i == j@@ -211,10 +203,6 @@   -- NOTE: hash based on original text rather than id   hashWithSalt s (S _ t _) = hashWithSalt s t -instance Binder Symbol where-  wildcard = vv Nothing-  editDistance s1 s2 = levenshteinDistance (symbolString s1) (symbolString s2)- instance NFData Symbol where   rnf S {} = () @@ -224,20 +212,8 @@   size = contramap symbolText S.size  instance B.Binary Symbol where-  get = textSymbol <$> B.get-  put = B.put . symbolText--instance Aeson.ToJSON Symbol where-  toJSON = Aeson.toJSON . symbolText--instance Aeson.FromJSON Symbol where-  parseJSON = fmap textSymbol . Aeson.parseJSON--instance Aeson.ToJSONKey Symbol where-  toJSONKey = Aeson.toJSONKeyText symbolText--instance Aeson.FromJSONKey Symbol where-  fromJSONKey = Aeson.FromJSONKeyText textSymbol+   get = textSymbol <$> B.get+   put = B.put . symbolText  sCache :: Cache Symbol sCache = mkCache@@ -262,7 +238,7 @@   toFix = text . T.unpack  {- | [NOTE: SymbolText]-        Use `symbolSafeText` if you want it to machine-readable,+	Use `symbolSafeText` if you want it to machine-readable,         but `symbolText`     if you want it to be human-readable.  -} @@ -353,7 +329,10 @@ isUnsafeChar :: Char -> Bool isUnsafeChar c =   let ic = ord c-   in ic >= Arr.numElements okSymChars || not (okSymChars Arr.! ic)+   in if ic < Arr.numElements okSymChars then+        not (okSymChars Arr.! ic)+      else+        True  keywords :: S.HashSet T.Text keywords   = S.fromList [ "env"@@ -414,6 +393,9 @@ unconsSym :: Symbol -> Maybe (Char, Symbol) unconsSym (symbolText -> s) = second symbol <$> T.uncons s +-- singletonSym :: Char -> Symbol -- Yuck+-- singletonSym = (`consSym` "")+ lengthSym :: Symbol -> Int lengthSym (symbolText -> t) = T.length t @@ -447,16 +429,23 @@ 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 vv Nothing          = vvName  isNontrivialVV      :: Symbol -> Bool-isNontrivialVV      = (vv Nothing /=)+isNontrivialVV      = not . (vv Nothing ==)  vvCon, dummySymbol :: Symbol vvCon       = vvName `suffixSymbol` "F" dummySymbol = dummyName +-- ctorSymbol :: Symbol -> Symbol+-- ctorSymbol s = ctorPrefix `mappendSym` s++-- isCtorSymbol :: Symbol -> Bool+-- isCtorSymbol = isPrefixOfSym ctorPrefix+ -- | 'testSymbol c' creates the `is-c` symbol for the adt-constructor named 'c'. testSymbol :: Symbol -> Symbol testSymbol s = testPrefix `mappendSym` s@@ -482,9 +471,6 @@ tempSymbol :: Symbol -> Integer -> Symbol tempSymbol prefix = intSymbol (tempPrefix `mappendSym` prefix) -renameSubstSymbol :: Symbol -> Int -> Symbol-renameSubstSymbol prefix = intSymbol (substPrefix `mappendSym` prefix)- renameSymbol :: Symbol -> Int -> Symbol renameSymbol prefix = intSymbol (renamePrefix `mappendSym` prefix) @@ -494,9 +480,8 @@ existSymbol :: Symbol -> Integer -> Symbol existSymbol prefix = intSymbol (existPrefix `mappendSym` prefix) -hvarArgSymbol :: Symbol -> Int -> Symbol-hvarArgSymbol s i = intSymbol (suffixSymbol hvarPrefix s) i-+gradIntSymbol :: Integer -> Symbol+gradIntSymbol = intSymbol gradPrefix  -- | Used to define functions corresponding to binding predicates --@@ -504,66 +489,28 @@ bindSymbol :: Integer -> Symbol bindSymbol = intSymbol bindPrefix -tempPrefix, anfPrefix, renamePrefix, substPrefix, litPrefix, bindPrefix :: Symbol+tempPrefix, anfPrefix, renamePrefix, litPrefix, gradPrefix, bindPrefix :: Symbol tempPrefix   = "lq_tmp$" anfPrefix    = "lq_anf$" renamePrefix = "lq_rnm$"-substPrefix = "subst$" litPrefix    = "lit$"+gradPrefix   = "grad$" bindPrefix   = "b$"  testPrefix  :: Symbol testPrefix   = "is$" -kArgPrefix, existPrefix, hvarPrefix :: Symbol-kArgPrefix  = "lq_karg$"-existPrefix = "lq_ext$"-hvarPrefix  = "nnf_arg$"---- | `unKArgSymbol` is like `tidySymbol` (see comment below) except it---    (a) *removes* the argument-index, and---    (b) *preserves* the `nnf_arg` (without replacing it with `$`)---    For example `unKArgSymbol lq_karg$nnf_arg$##k0##0##k0` ---> `nnf_arg##k0`--unKArgSymbol :: Symbol -> Symbol-unKArgSymbol = unSuffixSymbol . unSuffixSymbol . unPrefixSymbol kArgPrefix+-- ctorPrefix  :: Symbol+-- ctorPrefix   = "mk$" --- | @tidySymbol@ is used to prettify the names of parameters of kvars appearing--- in solutions.  For example, if you have a kvar $k0 with two parameters, you--- may have a solution that looks like------ > 0 <  lq_karg$nnf_arg$##k0##0##k0------   where we know it is a kvar-arg because of the---      - @kArgPrefix@ (@lq_arg@)---      - @hvarArgPrefix@ (@nnf_arg@)---      - @k0@ the name of the kvar---      - @0@  the parameter index---      - @k0@ again (IDK why?!)---    all of which are separated by @##@------   So @tidySymbol@ tests if indeed it is a @kArgPrefix@-ed symbol and if so---   converts------ > lq_karg$nnf_arg$##k0##0##k0 ----> $k0##0------  KArgs from Liquid Haskell come in the form @k_##0@ instead, and parameters---  are like @lq_karg$param_name##0##k_##0@. In this case, tidySymbol will---  convert------  > lq_karg$param_name##0##k_##0  ----> $param_name##0##k_+kArgPrefix, existPrefix :: Symbol+kArgPrefix   = "lq_karg$"+existPrefix  = "lq_ext$" +------------------------------------------------------------------------- tidySymbol :: Symbol -> Symbol-tidySymbol s-  | s == s'   = s-  | otherwise = s''-  where-    s' = unPrefixSymbol kArgPrefix s-    s'' =-      consSym '$' $-      unPrefixSymbol symSepName $-      unSuffixSymbol $-      unPrefixSymbol hvarPrefix s'+-------------------------------------------------------------------------+tidySymbol = unSuffixSymbol . unSuffixSymbol . unPrefixSymbol kArgPrefix  unPrefixSymbol :: Symbol -> Symbol -> Symbol unPrefixSymbol p s = fromMaybe s (stripPrefix p s)@@ -572,6 +519,10 @@ unSuffixSymbol s@(symbolText -> t)   = maybe s symbol $ T.stripSuffix symSepName $ fst $ T.breakOnEnd symSepName t +-- takeWhileSym :: (Char -> Bool) -> Symbol -> Symbol+-- takeWhileSym p (symbolText -> t) = symbol $ T.takeWhile p t++ nonSymbol :: Symbol nonSymbol = "" @@ -601,10 +552,10 @@ symbolBuilder = Builder.fromText . symbolSafeText . symbol  {-# INLINE buildMany #-}-buildMany :: [Builder] -> Builder+buildMany :: [Builder.Builder] -> Builder.Builder buildMany []     = mempty buildMany [b]    = b-buildMany (b:bs) = b <> mconcat [ " " <> b' | b' <- bs ]+buildMany (b:bs) = b <> mconcat [ " " <> b | b <- bs ]  ---------------------------------------------------------------------------- --------------- Global Name Definitions ------------------------------------@@ -616,23 +567,16 @@ lamArgPrefix :: Symbol lamArgPrefix = "lam_arg" -etaExpPrefix :: Symbol-etaExpPrefix = "eta"--etaExpSymbol :: Int -> Symbol-etaExpSymbol = intSymbol etaExpPrefix- lamArgSymbol :: Int -> Symbol lamArgSymbol = intSymbol lamArgPrefix  isLamArgSymbol :: Symbol -> Bool isLamArgSymbol = isPrefixOfSym lamArgPrefix -setToIntName, bitVecToIntName, mapToIntName, bagToIntName, realToIntName, toIntName, tyCastName :: Symbol+setToIntName, bitVecToIntName, mapToIntName, realToIntName, toIntName, tyCastName :: Symbol setToIntName    = "set_to_int" bitVecToIntName = "bitvec_to_int" mapToIntName    = "map_to_int"-bagToIntName    = "bag_to_int" realToIntName   = "real_to_int" toIntName       = "cast_as_int" tyCastName      = "cast_as"@@ -654,61 +598,53 @@ coerceName :: Symbol coerceName = "coerce" -preludeName, dummyName, boolConName, boolLConName, funConName :: Symbol+preludeName, dummyName, boolConName, funConName :: Symbol preludeName  = "Prelude" dummyName    = "LIQUID$dummy" boolConName  = "Bool"-boolLConName = "bool" funConName   = "->"  -listConName, listLConName, propConName, _hpropConName, vvName, setConName, mapConName, bagConName, arrayConName, ffldConName :: Symbol-listConName   = "[]"-listLConName  = "List"-setConName    = "Set_Set"-mapConName    = "Map_t"-bagConName    = "Bag_t"-arrayConName  = "Array_t"-ffldConName   = "FFld_t"-vvName        = "VV"-propConName   = "Prop"+listConName, listLConName, tupConName, propConName, _hpropConName, vvName, setConName, mapConName :: Symbol+listConName  = "[]"+listLConName = "List"+tupConName   = "Tuple"+setConName   = "Set_Set"+mapConName   = "Map_t"+vvName       = "VV"+propConName  = "Prop" _hpropConName = "HProp"  strConName, charConName :: (IsString a) => a strConName   = "Str" charConName  = "Char"+-- symSepName   :: Char+-- symSepName   = '#' -- DO NOT EVER CHANGE THIS  symSepName   :: (IsString a) => a symSepName   = "##" -intbv32Name, intbv64Name, bv32intName, bv64intName :: Symbol-intbv32Name = "int_to_bv32"-intbv64Name = "int_to_bv64"-bv32intName = "bv32_to_int"-bv64intName = "bv64_to_int"--intbv8Name, intbv16Name, bv8intName, bv16intName :: Symbol-intbv8Name  = "int_to_bv8"-intbv16Name = "int_to_bv16"-bv8intName  = "bv8_to_int"-bv16intName = "bv16_to_int"--nilName, consName, sizeName, bitVecName :: Symbol-nilName       = "nil"-consName      = "cons"-sizeName      = "Size"-bitVecName    = "BitVec"+nilName, consName, size32Name, size64Name, bitVecName, bvOrName, bvAndName :: Symbol+nilName      = "nil"+consName     = "cons"+size32Name   = "Size32"+size64Name   = "Size64"+bitVecName   = "BitVec"+bvOrName     = "bvor"+bvAndName    = "bvand" +-- HKT tyAppName :: Symbol+-- HKT tyAppName    = "LF-App"  mulFuncName, divFuncName :: Symbol-mulFuncName  = "SMTLIB_OP_MUL"-divFuncName  = "SMTLIB_OP_DIV"+mulFuncName  = "Z3_OP_MUL"+divFuncName  = "Z3_OP_DIV" -isPrim :: Symbol -> Bool-isPrim x = S.member x prims+isPrim :: Symbol -> Bool +isPrim x = S.member x prims   prims :: S.HashSet Symbol-prims = S.fromList+prims = S.fromList    [ propConName   , _hpropConName   , vvName@@ -716,6 +652,8 @@   , "List"   , "[]"   , "bool"+  -- , "int"+  -- , "real"   , setConName   , charConName   , "Set_sng"@@ -731,14 +669,11 @@   , "Map_store"   , "Map_union"   , "Map_default"-  , arrayConName-  -- Currently we parse X in "SizeX" to get the bitvec size-  -- so there is no finite set of names to add here...-  -- , size32Name-  -- , size64Name+  , size32Name+  , size64Name   , bitVecName-  -- , bvOrName-  -- , bvAndName+  , bvOrName+  , bvAndName   , "FAppTy"   , nilName   , consName
src/Language/Fixpoint/Types/PrettyPrint.hs view
@@ -13,6 +13,10 @@ import qualified Data.List           as L import           Language.Fixpoint.Misc import           Data.Hashable+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup (Semigroup (..))+#endif+ import qualified Data.Text as T  traceFix     ::  (Fixpoint a) => String -> a -> a@@ -31,12 +35,6 @@   toFix xs = brackets $ sep $ punctuate ";" (toFix <$> L.sort (S.toList xs))   simplify = S.fromList . map simplify . S.toList -instance (Ord k, Hashable k, Fixpoint k, Fixpoint v) => Fixpoint (M.HashMap k v) where-  toFix m = case hashMapToAscList m of-              []  -> empty-              xys -> hcat $ map (\(x,y) -> brackets $ toFix x <-> text ":=" <-> toFix y) xys-  simplify = M.map simplify . M.mapKeys simplify- instance Fixpoint () where   toFix _ = "()" @@ -99,11 +97,10 @@ notracepp :: (PPrint a) => String -> a -> a notracepp _ x = x - instance PPrint Doc where   pprintTidy _ = id -instance (PPrint a, PPrint b) => PPrint (Either a b) where+instance (PPrint a, PPrint b) => PPrint (Either a b) where    pprintTidy k (Left  a) = "Left"  <+> pprintTidy k a   pprintTidy k (Right b) = "Right" <+> pprintTidy k b @@ -118,10 +115,6 @@  instance (Ord a, PPrint a, PPrint b) => PPrint (M.HashMap a b) where   pprintTidy k = pprintKVs k . hashMapToAscList--instance PPrint Char where-  pprintTidy _ = char-  pprintKVs   :: (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc pprintKVs t = vcat . punctuate "\n" . map pp1
src/Language/Fixpoint/Types/Refinements.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE FlexibleContexts           #-}@@ -12,12 +13,9 @@ {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE GADTs                      #-}+{-# LANGUAGE PatternGuards              #-} {-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE ViewPatterns               #-}-{-# LANGUAGE TypeFamilies               #-} -{-# OPTIONS_GHC -Wno-orphans            #-}- -- | This module has the types for representing terms in the refinement logic.  module Language.Fixpoint.Types.Refinements (@@ -27,22 +25,16 @@   , Constant (..)   , Bop (..)   , Brel (..)-  , ExprBV (..)-  , ExprV, Pred-  , Expr+  , Expr (..), Pred+  , GradInfo (..)   , pattern PTrue, pattern PTop, pattern PFalse, pattern EBot   , pattern ETimes, pattern ERTimes, pattern EDiv, pattern ERDiv   , pattern EEq   , KVar (..)-  , Subst-  , SubstV (..)-  , KVarSubst+  , Subst (..)   , KVSub (..)-  , Reft-  , ReftV-  , ReftBV (..)+  , Reft (..)   , SortedReft (..)-  , TyVarSubst    -- * Constructing Terms   , eVar, elit@@ -59,6 +51,7 @@   , Expression (..)   , Predicate (..)   , Subable (..)+  , Reftable (..)    -- * Constructors   , reft                    -- "smart@@ -73,52 +66,45 @@   , predReft                -- any pred : p   , reftPred   , reftBind-  , toKVarSubst    -- * Predicates   , isFunctionSortedReft, functionSort   , isNonTrivial   , isContraPred   , isTautoPred-  , isTautoReft-  , isSingletonExpr+  , isSingletonExpr    , isSingletonReft   , isFalse    -- * Destructing   , flattenRefas-  , conjuncts, concConjuncts-  , dropECst+  , conjuncts   , eApps   , eAppC-  , eCst   , exprKVars   , exprSymbolsSet   , splitEApp-  , splitEAppThroughECst   , splitPAnd   , reftConjuncts   , sortedReftSymbols   , substSortInExpr-  , sortSubstInExpr-  , fromKVarSubst-  , isEmptyKVarSubst    -- * Transforming   , mapPredReft   , onEverySubexpr-  , mapBindExpr   , pprintReft-  , mapKVarSubst-  , mapBindKVarSubst-  , mapBindReft    , debruijnIndex +  -- * Gradual Type Manipulation+  , pGAnds, pGAnd+  , HasGradual (..)+  , srcGradInfo+   ) where  import           Prelude hiding ((<>))-import           Data.Bifunctor (first, second)+import           Data.Bifunctor (second) import qualified Data.Store as S import           Data.Generics             (Data, gmapT, mkT, extT) import           Data.Typeable             (Typeable)@@ -128,12 +114,7 @@ import           Data.HashSet              (HashSet) import qualified Data.HashSet              as HashSet import           GHC.Generics              (Generic)-import           GHC.Stack                 (HasCallStack)-#if MIN_VERSION_base(4,20,0)-import           Data.List                 (partition)-#else import           Data.List                 (foldl', partition)-#endif import qualified Data.Set                  as Set import           Data.String import           Data.Text                 (Text)@@ -142,40 +123,41 @@ import           Control.DeepSeq import           Data.Maybe                (isJust) import           Language.Fixpoint.Types.Names-import           Language.Fixpoint.Types.Binders import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Spans import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Misc import           Text.PrettyPrint.HughesPJ.Compat import qualified Data.Binary as B-import           Data.Aeson  -- import           Text.Printf               (printf)   instance NFData KVar-instance NFData v => NFData (SubstV v)+instance NFData SrcSpan+instance NFData Subst+instance NFData GradInfo instance NFData Constant instance NFData SymConst instance NFData Brel instance NFData Bop-instance (NFData b, NFData v) => NFData (KVarSubst b v)-instance (NFData b, NFData v) => NFData (ExprBV b v)-instance NFData v => NFData (ReftV v)+instance NFData Expr+instance NFData Reft instance NFData SortedReft  -- 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, 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 (KVarSubst Symbol Symbol) instance S.Store Expr instance S.Store Reft instance S.Store SortedReft@@ -183,6 +165,8 @@ instance B.Binary SymConst instance B.Binary Constant instance B.Binary Bop+instance B.Binary SrcSpan+instance B.Binary GradInfo instance B.Binary Brel instance B.Binary KVar instance (Hashable a, Eq a, B.Binary a) => B.Binary (HashSet a) where@@ -192,36 +176,65 @@   put = B.put . M.toList   get = M.fromList <$> B.get -instance (B.Binary v, Hashable v) => B.Binary (SubstV v)-instance (B.Binary b, B.Binary v) => B.Binary (KVarSubst b v)-instance (B.Binary b, B.Binary v) => B.Binary (ExprBV b v)-instance B.Binary v => B.Binary (ReftV v)+instance B.Binary Subst +instance B.Binary Expr+instance B.Binary Reft +instance B.Binary TCArgs+instance (Eq a, Hashable a, B.Binary a) => B.Binary (TCEmb a)   reftConjuncts :: Reft -> [Reft] reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- ras']   where-    ras'                     = if null ps then ks else conj ps : ks  -- see [NOTE:pAnd-SLOW]-    (ps, ks)                 = partition isConc (conjuncts ra)+    ras'                     = if null ps then ks else ((conj ps) : ks)  -- see [NOTE:pAnd-SLOW]+    (ks, ps)                 = partition (\p -> isKvar p || isGradual p) $ refaConjuncts ra -isConc :: Expr -> Bool-isConc p = not (isKvar p) -concConjuncts :: Expr -> [Expr]-concConjuncts e = filter isConc (conjuncts e)  isKvar :: Expr -> Bool-isKvar (PKVar {}) = True+isKvar (PKVar _ _) = True isKvar _           = False +class HasGradual a where+  isGradual :: a -> Bool+  gVars     :: a -> [KVar]+  gVars _ = [] +  ungrad    :: a -> a+  ungrad x = x ++instance HasGradual Expr where+  isGradual (PGrad {}) = True+  isGradual (PAnd xs)  = any isGradual xs+  isGradual _          = False++  gVars (PGrad k _ _ _) = [k]+  gVars (PAnd xs)       = concatMap gVars xs+  gVars _               = []++  ungrad (PGrad {}) = PTrue+  ungrad (PAnd xs)  = PAnd (ungrad <$> xs )+  ungrad e          = e+++instance HasGradual Reft where+  isGradual (Reft (_,r)) = isGradual r+  gVars (Reft (_,r))     = gVars r+  ungrad (Reft (x,r))    = Reft(x, ungrad r)++instance HasGradual SortedReft where+  isGradual = isGradual . sr_reft+  gVars     = gVars . sr_reft+  ungrad r  = r {sr_reft = ungrad (sr_reft r)}++refaConjuncts :: Expr -> [Expr]+refaConjuncts p = [p' | p' <- conjuncts p, not $ isTautoPred p']+ -------------------------------------------------------------------------------- -- | Kvars --------------------------------------------------------------------- --------------------------------------------------------------------------------  newtype KVar = KV { kv :: Symbol }-               deriving (Eq, Ord, Data, Typeable, Generic, IsString, ToJSON, FromJSON)--instance ToJSONKey KVar+               deriving (Eq, Ord, Data, Typeable, Generic, IsString)  intKvar :: Integer -> KVar intKvar = KV . intSymbol "k_"@@ -234,63 +247,33 @@ instance Hashable Bop instance Hashable SymConst instance Hashable Constant-instance Hashable v => Hashable (SubstV v)-instance (Hashable b, Hashable v) => Hashable (KVarSubst b v)-instance (Hashable b, Hashable v) => Hashable (ExprBV b v)-instance Hashable v => Hashable (ReftV v)+instance Hashable GradInfo +instance Hashable Subst +instance Hashable Expr +instance Hashable Reft  -------------------------------------------------------------------------------- -- | Substitutions ------------------------------------------------------------- ---------------------------------------------------------------------------------type Subst = SubstV Symbol-newtype SubstV v = Su (M.HashMap v (ExprBV v v))+newtype Subst = Su (M.HashMap Symbol Expr)                 deriving (Eq, Data, Ord, Typeable, Generic) -instance ToJSON Subst-instance FromJSON Subst--instance (Fixpoint v, Ord v, Hashable v, Show v) => Show (SubstV v) where-  show = showFix--instance (Ord v, Hashable v, Fixpoint v) => Fixpoint (SubstV v) where-  toFix (Su m) = toFix m--instance (Ord v, Hashable v, Fixpoint v) => PPrint (SubstV v) where-  pprintTidy _ = toFix--newtype KVarSubst b v = KSu [(b, ExprBV b v)]-  deriving (Eq, Ord, Data, Typeable, Generic, Functor, Foldable, Traversable)--fromKVarSubst :: Hashable b => KVarSubst b v -> M.HashMap b (ExprBV b v)-fromKVarSubst (KSu su) = M.fromList su--toKVarSubst :: M.HashMap b (ExprBV b v) -> KVarSubst b v-toKVarSubst = KSu . M.toList--mapKVarSubst :: (ExprBV b v -> ExprBV b v) -> KVarSubst b v -> KVarSubst b v-mapKVarSubst f (KSu su) = KSu $ fmap (fmap f) su--mapBindKVarSubst :: (Hashable b, Hashable b') => (b -> b') -> KVarSubst b v -> KVarSubst b' v-mapBindKVarSubst f = toKVarSubst . fmap (mapBindExpr f) . M.mapKeys f . fromKVarSubst--isEmptyKVarSubst :: KVarSubst b v -> Bool-isEmptyKVarSubst (KSu su) = null su--instance (Ord v, Fixpoint v, Ord b, Fixpoint b, Hashable b) => Show (KVarSubst b v) where+instance Show Subst where   show = showFix -instance (Ord v, Fixpoint v, Ord b, Fixpoint b, Hashable b) => Fixpoint (KVarSubst b v) where-  toFix = toFix . fromKVarSubst+instance Fixpoint Subst where+  toFix (Su m) = case hashMapToAscList m of+                   []  -> empty+                   xys -> hcat $ map (\(x,y) -> brackets $ toFix x <-> text ":=" <-> toFix y) xys -instance (Ord v, Fixpoint v, Ord b, Fixpoint b, Hashable b) => PPrint (KVarSubst b v) where+instance PPrint Subst where   pprintTidy _ = toFix  data KVSub = KVS   { ksuVV    :: Symbol   , ksuSort  :: Sort   , ksuKVar  :: KVar-  , ksuSubst :: KVarSubst Symbol Symbol-  , ksuTySub :: M.HashMap Symbol Sort  -- ^ Type variable substitution+  , ksuSubst :: Subst   } deriving (Eq, Data, Typeable, Generic, Show)  instance PPrint KVSub where@@ -302,8 +285,8 @@  -- | Uninterpreted constants that are embedded as  "constant symbol : Str" -newtype SymConst = SL Text-                   deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+data SymConst = SL !Text+              deriving (Eq, Ord, Show, Data, Typeable, Generic)  data Constant = I !Integer               | R !Double@@ -317,50 +300,29 @@             deriving (Eq, Ord, Show, Data, Typeable, Generic)             -- NOTE: For "Mod" 2nd expr should be a constant or a var *) -instance ToJSON Constant  where-instance ToJSON Brel      where-instance ToJSON Bop       where-instance ToJSON (KVarSubst Symbol Symbol) where-instance ToJSON Expr      where--instance FromJSON Constant  where-instance FromJSON Brel      where-instance FromJSON Bop       where-instance FromJSON (KVarSubst Symbol Symbol) where-instance FromJSON Expr      where---type Expr = ExprV Symbol-type ExprV v = ExprBV Symbol v-type TyVarSubst = M.HashMap Symbol Sort--data ExprBV b v-          = ESym !SymConst+data Expr = ESym !SymConst           | ECon !Constant-          | EVar !v-          | EApp !(ExprBV b v) !(ExprBV b v)-          | ENeg !(ExprBV b v)-          | EBin !Bop !(ExprBV b v) !(ExprBV b v)-          | ELet !b !(ExprBV b v) !(ExprBV b v)-          | EIte !(ExprBV b v) !(ExprBV b v) !(ExprBV b v)-          | ECst !(ExprBV b v) !Sort-          | ELam !(b, Sort)   !(ExprBV b v)-          | ETApp !(ExprBV b v) !Sort-          | ETAbs !(ExprBV b v) !b-          | PAnd   ![ExprBV b v]-          | POr    ![ExprBV b v]-          | PNot   !(ExprBV b v)-          | PImp   !(ExprBV b v) !(ExprBV b v)-          | PIff   !(ExprBV b v) !(ExprBV b v)-          | PAtom  !Brel  !(ExprBV b v) !(ExprBV b v)-            -- | In @PKVar k su tsu@, @k@ is the KVar, @su@ is the substitution-            -- for that KVar, and @tsu@ indicates how to instantiate type-            -- variables that could appear in the KVar solution.-          | PKVar  !KVar !TyVarSubst !(KVarSubst b v)-          | PAll   ![(b, Sort)] !(ExprBV b v)-          | PExist ![(b, Sort)] !(ExprBV b v)-          | ECoerc !Sort !Sort !(ExprBV b v)-          deriving (Eq, Show, Ord, Data, Typeable, Generic, Functor, Foldable, Traversable)+          | EVar !Symbol+          | EApp !Expr !Expr+          | ENeg !Expr+          | EBin !Bop !Expr !Expr+          | EIte !Expr !Expr !Expr+          | ECst !Expr !Sort+          | ELam !(Symbol, Sort)   !Expr+          | ETApp !Expr !Sort+          | ETAbs !Expr !Symbol+          | PAnd   ![Expr]+          | POr    ![Expr]+          | PNot   !Expr+          | PImp   !Expr !Expr+          | PIff   !Expr !Expr+          | PAtom  !Brel  !Expr !Expr+          | PKVar  !KVar !Subst+          | PAll   ![(Symbol, Sort)] !Expr+          | PExist ![(Symbol, Sort)] !Expr+          | PGrad  !KVar !Subst !GradInfo !Expr+          | ECoerc !Sort !Sort !Expr  +          deriving (Eq, Show, Ord, Data, Typeable, Generic)  onEverySubexpr :: (Expr -> Expr) -> Expr -> Expr onEverySubexpr = everywhereOnA@@ -375,60 +337,34 @@  type Pred = Expr -pattern PTrue :: ExprBV b v+pattern PTrue :: Expr pattern PTrue = PAnd [] -pattern PTop :: ExprBV b v+pattern PTop :: Expr pattern PTop = PAnd [] -pattern PFalse :: ExprBV b v+pattern PFalse :: Expr pattern PFalse = POr  [] -pattern EBot :: ExprBV b v+pattern EBot :: Expr pattern EBot = POr  [] -pattern EEq :: ExprBV b v -> ExprBV b v -> ExprBV b v+pattern EEq :: Expr -> Expr -> Expr pattern EEq e1 e2 = PAtom Eq    e1 e2 -pattern ETimes :: ExprBV b v -> ExprBV b v -> ExprBV b v+pattern ETimes :: Expr -> Expr -> Expr pattern ETimes e1 e2 = EBin Times  e1 e2 -pattern ERTimes :: ExprBV b v -> ExprBV b v -> ExprBV b v+pattern ERTimes :: Expr -> Expr -> Expr pattern ERTimes e1 e2 = EBin RTimes e1 e2 -pattern EDiv :: ExprBV b v -> ExprBV b v -> ExprBV b v+pattern EDiv :: Expr -> Expr -> Expr pattern EDiv e1 e2 = EBin Div    e1 e2 -pattern ERDiv :: ExprBV b v -> ExprBV b v -> ExprBV b v+pattern ERDiv :: Expr -> Expr -> Expr pattern ERDiv e1 e2 = EBin RDiv   e1 e2 -mapBindExpr :: (Hashable b, Hashable b') => (b -> b') -> ExprBV b v -> ExprBV b' v-mapBindExpr f = go-  where-    go (ESym c) = ESym c-    go (ECon c) = ECon c-    go (EVar v) = EVar v-    go (EApp e1 e2) = EApp (go e1) (go e2)-    go (ENeg e) = ENeg (go e)-    go (EBin op e1 e2) = EBin op (go e1) (go e2)-    go (ELet b e1 e2) = ELet (f b) (go e1) (go e2)-    go (EIte e1 e2 e3) = EIte (go e1) (go e2) (go e3)-    go (ECst e s) = ECst (go e) s-    go (ELam (b, s) e) = ELam (f b, s) (go e)-    go (ETApp e s) = ETApp (go e) s-    go (ETAbs e b) = ETAbs (go e) (f b)-    go (PAnd es) = PAnd (go <$> es)-    go (POr es) = POr (go <$> es)-    go (PNot e) = PNot (go e)-    go (PImp e1 e2) = PImp (go e1) (go e2)-    go (PIff e1 e2) = PIff (go e1) (go e2)-    go (PAtom rel e1 e2) = PAtom rel (go e1) (go e2)-    go (PKVar k tsu su) = PKVar k tsu (mapBindKVarSubst f su)-    go (PAll bs e) = PAll (first f <$> bs) (go e)-    go (PExist bs e) = PExist (first f <$> bs) (go e)-    go (ECoerc s1 s2 e) = ECoerc s1 s2 (go e)--exprSymbolsSet :: (Eq v, Hashable v) => ExprBV v v -> HashSet v+exprSymbolsSet :: Expr -> HashSet Symbol exprSymbolsSet = go   where     gos es                = HashSet.unions (go <$> es)@@ -438,7 +374,6 @@     go (ECoerc _ _ e)     = go e     go (ENeg e)           = go e     go (EBin _ e1 e2)     = gos [e1, e2]-    go (ELet x e1 e2)     = HashSet.union (go e1) (HashSet.delete x $ go e2)     go (EIte p e1 e2)     = gos [p, e1, e2]     go (ECst e _)         = go e     go (PAnd ps)          = gos ps@@ -447,7 +382,7 @@     go (PIff p1 p2)       = gos [p1, p2]     go (PImp p1 p2)       = gos [p1, p2]     go (PAtom _ e1 e2)    = gos [e1, e2]-    go (PKVar _ _ su)       = HashSet.unions $ map exprSymbolsSet (M.elems $ fromKVarSubst su)+    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@@ -463,19 +398,7 @@       ECoerc t0 t1 e -> ECoerc (substSort f t0) (substSort f t1) e       e -> e --sortSubstInExpr :: SortSubst -> Expr -> Expr-sortSubstInExpr f = onEverySubexpr go-  where-    go = \case-      ELam (x, t) e -> ELam (x, sortSubst f t) e-      PAll xts e -> PAll (second (sortSubst f) <$> xts) e-      PExist xts e -> PExist (second (sortSubst f) <$> xts) e-      ECst e t -> ECst e (sortSubst f t)-      ECoerc t0 t1 e -> ECoerc (sortSubst f t0) (sortSubst f t1) e-      e -> e--exprKVars :: Expr -> HashMap KVar [KVarSubst Symbol Symbol]+exprKVars :: Expr -> HashMap KVar [Subst] exprKVars = go   where     gos es                = HashMap.unions (go <$> es)@@ -485,7 +408,6 @@     go (ECoerc _ _ e)     = go e     go (ENeg e)           = go e     go (EBin _ e1 e2)     = gos [e1, e2]-    go (ELet _ e1 e2)     = gos [e1, e2]     go (EIte p e1 e2)     = gos [p, e1, e2]     go (ECst e _)         = go e     go (PAnd ps)          = gos ps@@ -494,45 +416,36 @@     go (PIff p1 p2)       = gos [p1, p2]     go (PImp p1 p2)       = gos [p1, p2]     go (PAtom _ e1 e2)    = gos [e1, e2]-    go (PKVar k _ su) =-      HashMap.insertWith (++) k [su] $ HashMap.unions $ map exprKVars (M.elems $ fromKVarSubst su)+    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 -mkEApp :: Located v -> [ExprBV b v] -> ExprBV b v+data GradInfo = GradInfo {gsrc :: SrcSpan, gused :: Maybe SrcSpan}+          deriving (Eq, Ord, Show, Data, Typeable, Generic)++srcGradInfo :: SourcePos -> GradInfo+srcGradInfo src = GradInfo (SS src src) Nothing++mkEApp :: LocSymbol -> [Expr] -> Expr mkEApp = eApps . EVar . val -eApps :: ExprBV b v -> [ExprBV b v] -> ExprBV b v+eApps :: Expr -> [Expr] -> Expr eApps f es  = foldl' EApp f es -splitEApp :: ExprBV b v -> (ExprBV b v, [ExprBV b v])+splitEApp :: Expr -> (Expr, [Expr]) splitEApp = go []   where     go acc (EApp f e) = go (e:acc) f     go acc e          = (e, acc) -splitEAppThroughECst :: Expr -> (Expr, [Expr])-splitEAppThroughECst = go []-  where-    go acc (dropECst -> (EApp f e)) = go (e:acc) f-    go acc e                        = (e, acc)--dropECst :: Expr -> Expr-dropECst e = case e of-  ECst e' _ -> dropECst e'-  _         -> e- splitPAnd :: Expr -> [Expr] splitPAnd (PAnd es) = concatMap splitPAnd es splitPAnd e         = [e]  eAppC :: Sort -> Expr -> Expr -> Expr-eAppC s e1 e2 = eCst (EApp e1 e2) s---- | Eliminates redundant casts-eCst :: Expr -> Sort -> Expr-eCst e s = ECst (dropECst e) s+eAppC s e1 e2 = ECst (EApp e1 e2) s  -------------------------------------------------------------------------------- debruijnIndex :: Expr -> Int@@ -546,37 +459,29 @@     go (EVar _)        = 1     go (ENeg e)        = go e     go (EBin _ e1 e2)  = go e1 + go e2-    go (ELet _ e1 e2)  = 1 + go e1 + go e2     go (EIte e e1 e2)  = go e + go e1 + go e2     go (ETAbs e _)     = go e     go (ETApp e _)     = go e-    go (PAnd es)       = foldl' (\n e -> n + go e) 0 es-    go (POr es)        = foldl' (\n e -> n + go e) 0 es+    go (PAnd es)       = foldl (\n e -> n + go e) 0 es+    go (POr es)        = foldl (\n e -> n + go e) 0 es     go (PNot e)        = go e     go (PImp e1 e2)    = go e1 + go e2     go (PIff e1 e2)    = go e1 + go e2     go (PAtom _ e1 e2) = go e1 + go e2     go (PAll _ e)      = go e     go (PExist _ e)    = go e-    go (PKVar {})        = 1+    go (PKVar _ _)     = 1+    go (PGrad _ _ _ e) = go e     go (ECoerc _ _ e)  = go e -type Reft = ReftV Symbol-type ReftV v = ReftBV Symbol v---- | Refinement of @v@ satisfying a predicate---   e.g. in '{x: _ | e }' x is the @Symbol@ and e the @ExprV v@-newtype ReftBV b v = Reft (b, ExprBV b v)-    deriving (Eq, Ord, Data, Typeable, Generic, Functor, Foldable, Traversable)--mapBindReft :: (Hashable b, Hashable b') => (b -> b') -> ReftBV b v -> ReftBV b' v-mapBindReft f (Reft (b, e)) = Reft (f b, mapBindExpr f e)+-- | 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, Ord, Data, Typeable, Generic)  data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft }                   deriving (Eq, Ord, Data, Typeable, Generic) -instance Hashable SortedReft- sortedReftSymbols :: SortedReft -> HashSet Symbol sortedReftSymbols sr =   HashSet.union@@ -604,6 +509,9 @@ encodeSymConst        :: SymConst -> Symbol encodeSymConst (SL s) = litSymbol $ symbol s +-- _decodeSymConst :: Symbol -> Maybe SymConst+-- _decodeSymConst = fmap (SL . symbolText) . unLitSymbol+ instance Fixpoint SymConst where   toFix (SL t) = text (show t) @@ -629,14 +537,13 @@   toFix RDiv   = text "/."   toFix Mod    = text "mod" -instance (Ord b, Fixpoint b, Hashable b, Ord v, Fixpoint v) => Fixpoint (ExprBV b v) where+instance Fixpoint Expr where   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 $ sep [toFix e1  <+> toFix o, nest 2 (toFix e2)]-  toFix (ELet x e1 e2) = parens $ sep [text "let" <+> toFix x <+> text "=" <+> toFix e1 <+> text "in", 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@@ -650,33 +557,22 @@   toFix (PAnd ps)      = text "&&" <+> toFix ps   toFix (POr  ps)      = text "||" <+> toFix ps   toFix (PAtom r e1 e2)  = parens $ sep [ toFix e1 <+> toFix r, nest 2 (toFix e2)]-  toFix (PKVar k tsu su)   = toFix k <-> toFixTySub tsu <-> toFix su-  toFix (PAll xts p)     = parens $ "forall" <+> (toFix xts+  toFix (PKVar k su)     = toFix k <-> toFix su+  toFix (PAll xts p)     = "forall" <+> (toFix xts                                         $+$ ("." <+> toFix p))-  toFix (PExist xts p)   = parens $ "exists" <+> (toFix xts+  toFix (PExist xts p)   = "exists" <+> (toFix xts                                         $+$ ("." <+> toFix p))   toFix (ETApp e s)      = text "tapp" <+> toFix e <+> toFix s   toFix (ETAbs e s)      = text "tabs" <+> toFix e <+> toFix s+  toFix (PGrad k _ _ e)  = toFix e <+> text "&&" <+> toFix k -- text "??" -- <+> toFix k <+> toFix su   toFix (ECoerc a t e)   = parens (text "coerce" <+> toFix a <+> text "~" <+> toFix t <+> text "in" <+> toFix e)-  toFix (ELam (x,s) e)   = parens (char '\\' <+> toFix x <+> ":" <+> toFix s <+> "->" <+> toFix e)--  simplify = simplifyExprDefault---- | Serialize a type-variable substitution for PKVar in .fq files.--- An empty substitution is rendered as @[@]@, and a non-empty one as--- @[\@sym:=sort;...]@.-toFixTySub :: M.HashMap Symbol Sort -> Doc-toFixTySub tsu-  | M.null tsu = empty-  | otherwise  = brackets (text "@" <->  tyPairs)-  where-    tyPairs = hcat $ punctuate (text ";") (toFixTyPair <$> hashMapToAscList tsu)-    toFixTyPair (s, srt) = toFix s <-> text ":=" <-> toFix srt+  toFix (ELam (x,s) e)   = text "lam" <+> toFix x <+> ":" <+> toFix s <+> "." <+> toFix e -simplifyExprDefault :: (Ord b, Ord v) => ExprBV b v -> ExprBV b v-simplifyExprDefault = simplifyExpr (Set.toList . Set.fromList)+  simplify = simplifyExpr dedup+    where+      dedup = Set.toList . Set.fromList -simplifyExpr :: (Eq b, Eq v) => ([ExprBV b v] -> [ExprBV b v]) -> ExprBV b v -> ExprBV b v+simplifyExpr :: ([Expr] -> [Expr]) -> Expr -> Expr simplifyExpr dedup = go   where     go (POr  [])     = PFalse@@ -703,6 +599,10 @@           else if sq == PFalse then PNot sp           else PIff sp sq +    go (PGrad k su i e)+      | isContraPred e      = PFalse+      | otherwise           = PGrad k su i (go e)+     go (PAnd ps)       | any isContraPred ps = PFalse                            -- Note: Performance of some tests is very sensitive to this code. See #480@@ -721,7 +621,7 @@       | isTautoPred  p     = PTrue       | otherwise          = p -isContraPred   :: (Eq b, Eq v) => ExprBV b v -> Bool+isContraPred   :: Expr -> Bool isContraPred z = eqC z || (z `elem` contras)   where     contras    = [PFalse]@@ -736,7 +636,7 @@                = x == y     eqC _      = False -isTautoPred   :: (Eq b, Eq v) => ExprBV b v -> Bool+isTautoPred   :: Expr -> Bool isTautoPred z  = z == PTop || z == PTrue || eqT z   where     eqT (PAnd [])@@ -769,6 +669,12 @@ instance PPrint Bop where   pprintTidy _  = toFix +instance PPrint Sort where+  pprintTidy _ = toFix++instance PPrint a => PPrint (TCEmb a) where +  pprintTidy k = pprintTidy k . tceToList + instance PPrint KVar where   pprintTidy _ (KV x) = text "$" <-> pprint x @@ -808,7 +714,7 @@ opPrec Div    = 7 opPrec RDiv   = 7 -instance (Ord b, Fixpoint b, Hashable b, PPrint b, Ord v, Fixpoint v, PPrint v) => PPrint (ExprBV b v) where+instance PPrint Expr where   pprintPrec _ k (ESym c)        = pprintTidy k c   pprintPrec _ k (ECon c)        = pprintTidy k c   pprintPrec _ k (EVar s)        = pprintTidy k s@@ -824,10 +730,6 @@                                    pprintTidy k o         <+>                                    pprintPrec (zo+1) k e2     where zo = opPrec o-  pprintPrec _ k (ELet x e1 e2)  = parens-                                   "let"  <+> toFix x <+> "=" <+> pprintTidy  k e1  <+>-                                   "in"   <+> pprintTidy k e2-   pprintPrec z k (EIte p e1 e2)  = parensIf (z > zi) $                                    "if"   <+> pprintPrec (zi+1) k p  <+>                                    "then" <+> pprintPrec (zi+1) k e1 <+>@@ -835,7 +737,7 @@     where zi = 1    -- RJ: DO NOT DELETE!-  pprintPrec _ k (ECst e so)     = parens $ pprint e <+> ":" <+> {- const (text "...") -} pprintTidy k so+  pprintPrec _ k (ECst e so)     = parens $ pprint e <+> ":" <+> {- const (text "...") -} (pprintTidy k so)   -- pprintPrec z k (ECst e _)      = pprintPrec z k e   pprintPrec _ _ PTrue           = trueD   pprintPrec _ _ PFalse          = falseD@@ -843,14 +745,14 @@                                    "not" <+> pprintPrec (zn+1) k p     where zn = 8   pprintPrec z k (PImp p1 p2)    = parensIf (z > zi) $-                                   pprintPrec (zi+1) k p1 <+>+                                   (pprintPrec (zi+1) k p1) <+>                                    "=>"                     <+>-                                   pprintPrec (zi+1) k p2+                                   (pprintPrec (zi+1) k p2)     where zi = 2   pprintPrec z k (PIff p1 p2)    = parensIf (z > zi) $-                                   pprintPrec (zi+1) k p1 <+>+                                   (pprintPrec (zi+1) k p1) <+>                                    "<=>"                    <+>-                                   pprintPrec (zi+1) k p2+                                   (pprintPrec (zi+1) k p2)     where zi = 2   pprintPrec z k (PAnd ps)       = parensIf (z > za) $                                    pprintBin (za + 1) k trueD andD ps@@ -863,18 +765,17 @@                                    pprintTidy k r         <+>                                    pprintPrec (za+1) k e2     where za = 4-  pprintPrec z k (PAll xts p)    = parensIf (z > 0) $ pprintQuant k "forall" xts p-  pprintPrec z k (PExist xts p)  = parensIf (z > 0) $ pprintQuant k "exists" xts p+  pprintPrec _ k (PAll xts p)    = pprintQuant k "forall" xts p+  pprintPrec _ k (PExist xts p)  = pprintQuant k "exists" xts p   pprintPrec _ k (ELam (x,t) e)  = "lam" <+> toFix x <+> ":" <+> toFix t <+> text "." <+> pprintTidy k e   pprintPrec _ k (ECoerc a t e)  = parens $ "coerce" <+> toFix a <+> "~" <+> toFix t <+> text "in" <+> pprintTidy k e-  pprintPrec _ _ p@PKVar{}    = toFix p+  pprintPrec _ _ p@(PKVar {})    = toFix p   pprintPrec _ _ (ETApp e s)     = "ETApp" <+> toFix e <+> toFix s   pprintPrec _ _ (ETAbs e s)     = "ETAbs" <+> toFix e <+> toFix s+  pprintPrec z k (PGrad x _ _ e) = pprintPrec z k e <+> "&&" <+> toFix x -- "??" -pprintQuant-  :: (Ord b, Fixpoint b, Hashable b, PPrint b, Ord v, Fixpoint v, PPrint v)-  => Tidy -> Doc -> [(b, Sort)] -> ExprBV b v -> Doc-pprintQuant k d xts p = (d <+> pprintTidy k xts)+pprintQuant :: Tidy -> Doc -> [(Symbol, Sort)] -> Expr -> Doc+pprintQuant k d xts p = (d <+> toFix xts)                         $+$                         ("  ." <+> pprintTidy k p) @@ -893,7 +794,7 @@ vIntersperse _ [d]    = d vIntersperse s (d:ds) = vcat (d : ((s <+>) <$> ds)) -pprintReft :: (PPrint v, Ord v, Fixpoint v) => Tidy -> ReftV v -> Doc+pprintReft :: Tidy -> Reft -> Doc pprintReft k (Reft (_,ra)) = pprintBin z k trueD andD flat   where     flat = flattenRefas [ra]@@ -961,14 +862,14 @@ isSingletonExpr v (PAtom r e1 e2)   | e1 == EVar v && isEq r = Just e2   | e2 == EVar v && isEq r = Just e1-isSingletonExpr v (PIff e1 e2)+isSingletonExpr v (PIff e1 e2)    | e1 == EVar v           = Just e2   | e2 == EVar v           = Just e1 isSingletonExpr _ _        = Nothing  -- | 'conj' is a fast version of 'pAnd' needed for the ebind tests conj :: [Pred] -> Pred-conj []  = PTrue+conj []  = PFalse conj [p] = p conj ps  = PAnd ps @@ -976,31 +877,29 @@ --   so they SHOULD NOT be used inside the solver loop. Instead, use 'conj' which ensures --   some basic things but is faster. -pAnd, pOr     :: (Ord b, Hashable b, Ord v) => ListNE (ExprBV b v) -> ExprBV b v-pAnd          = simplifyExprDefault . PAnd+pAnd, pOr     :: ListNE Pred -> Pred+pAnd          = simplify . PAnd  pAndNoDedup :: ListNE Pred -> Pred pAndNoDedup = simplifyExpr id . PAnd -pOr           = simplifyExprDefault . POr+pOr           = simplify . POr -infixl 9 &.& (&.&) :: Pred -> Pred -> Pred (&.&) p q = pAnd [p, q] -infixl 9 |.| (|.|) :: Pred -> Pred -> Pred (|.|) p q = pOr [p, q] -pIte :: (Fixpoint b, Ord b, Hashable b, Fixpoint v, Ord v) => ExprBV b v -> ExprBV b v -> ExprBV b v -> ExprBV b v-pIte p1 p2 p3 = pAnd [p1 `PImp` p2, PNot p1 `PImp` p3]+pIte :: Pred -> Expr -> Expr -> Expr+pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3] -pExist :: [(b, Sort)] -> ExprBV b v -> ExprBV b v+pExist :: [(Symbol, Sort)] -> Pred -> Pred pExist []  p = p pExist xts p = PExist xts p  mkProp :: Expr -> Pred-mkProp = id+mkProp = id -- EApp (EVar propConName)  -------------------------------------------------------------------------------- -- | Predicates ----------------------------------------------------------------@@ -1023,7 +922,7 @@ predReft      :: (Predicate a) => a -> Reft predReft p    = Reft (vv_, prop p) -reft :: Symbol -> ExprV v -> ReftV v+reft :: Symbol -> Expr -> Reft reft v p = Reft (v, p)  mapPredReft :: (Expr -> Expr) -> Reft -> Reft@@ -1036,19 +935,27 @@ isFunctionSortedReft :: SortedReft -> Bool isFunctionSortedReft = isJust . functionSort . sr_sort -isNonTrivial :: SortedReft -> Bool-isNonTrivial = not . isTautoReft . sr_reft--isTautoReft :: (Eq b, Eq v) => ReftBV b v -> Bool-isTautoReft = all isTautoPred . conjuncts . reftPred+isNonTrivial :: Reftable r => r -> Bool+isNonTrivial = not . isTauto -reftPred :: ReftBV b v -> ExprBV b v+reftPred :: Reft -> Expr reftPred (Reft (_, p)) = p -reftBind :: ReftBV b v -> b+reftBind :: Reft -> Symbol reftBind (Reft (x, _)) = x  ------------------------------------------------------------+-- | Gradual Type Manipulation  ----------------------------+------------------------------------------------------------+pGAnds :: [Expr] -> Expr+pGAnds = foldl pGAnd PTrue++pGAnd :: Expr -> Expr -> Expr+pGAnd (PGrad k su i p) q = PGrad k su i (pAnd [p, q])+pGAnd p (PGrad k su i q) = PGrad k su i (pAnd [p, q])+pGAnd p q              = pAnd [p,q]++------------------------------------------------------------ -- | Generally Useful Refinements -------------------------- ------------------------------------------------------------ @@ -1064,18 +971,18 @@ trueSortedReft :: Sort -> SortedReft trueSortedReft = (`RR` trueReft) -trueReft, falseReft :: Binder b => ReftBV b v-trueReft  = Reft (wildcard, PTrue)-falseReft = Reft (wildcard, PFalse)+trueReft, falseReft :: Reft+trueReft  = Reft (vv_, PTrue)+falseReft = Reft (vv_, PFalse) -flattenRefas :: [ExprBV b v] -> [ExprBV b v]+flattenRefas :: [Expr] -> [Expr] flattenRefas        = flatP []   where     flatP acc (PAnd ps:xs) = flatP (flatP acc xs) ps     flatP acc (p:xs)       = p : flatP acc xs     flatP acc []           = acc -conjuncts :: (Eq b, Eq v) => ExprBV b v -> [ExprBV b v]+conjuncts :: Expr -> [Expr] conjuncts (PAnd ps) = concatMap conjuncts ps conjuncts p   | isTautoPred p   = []@@ -1089,36 +996,46 @@ class Falseable a where   isFalse :: a -> Bool -instance Falseable (ExprBV b v) where+instance Falseable Expr where   isFalse PFalse = True   isFalse _      = False -instance Falseable (ReftBV b v) where+instance Falseable Reft where   isFalse (Reft (_, ra)) = isFalse ra  ------------------------------------------------------------------------- -- | Class Predicates for Valid Refinements ----------------------------- ------------------------------------------------------------------------- -class (Eq (Variable a), Hashable (Variable a)) => Subable a where-  type Variable a-  type Variable a = Symbol--  syms   :: a -> [Variable a]                   -- ^ free symbols of a-  substa :: (Variable a -> Variable a) -> a -> a+class Subable a where+  syms   :: a -> [Symbol]                   -- ^ free symbols of a+  substa :: (Symbol -> Symbol) -> a -> a   -- substa f  = substf (EVar . f) -  substf :: (Variable a -> ExprBV (Variable a) (Variable a)) -> a -> a-  subst  :: HasCallStack => SubstV (Variable a) -> a -> a-  subst1 :: a -> (Variable a, ExprBV (Variable a) (Variable a)) -> a+  substf :: (Symbol -> Expr) -> a -> a+  subst  :: Subst -> a -> a+  subst1 :: a -> (Symbol, Expr) -> a   subst1 y (x, e) = subst (Su $ M.fromList [(x,e)]) y  instance Subable a => Subable (Located a) where-  type Variable (Located a) = Variable a   syms (Loc _ _ x)   = syms x   substa f (Loc l l' x) = Loc l l' (substa f x)   substf f (Loc l l' x) = Loc l l' (substf f x)   subst su (Loc l l' x) = Loc l l' (subst su x) -instance Fixpoint Doc where-  toFix = id++class (Monoid r, Subable r) => Reftable r where+  isTauto :: r -> Bool+  ppTy    :: r -> Doc -> Doc++  top     :: r -> r+  top _   =  mempty++  bot     :: r -> r++  meet    :: r -> r -> r+  meet    = mappend++  toReft  :: r -> Reft+  ofReft  :: Reft -> r+  params  :: r -> [Symbol]          -- ^ parameters for Reft, vv + others
− src/Language/Fixpoint/Types/SMTPrint.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE FlexibleInstances  #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE ViewPatterns #-}--module Language.Fixpoint.Types.SMTPrint where---import qualified Language.Fixpoint.Misc  as Misc-import qualified Text.PrettyPrint.HughesPJ.Compat as P-import qualified Language.Fixpoint.Types.PrettyPrint as F-import qualified Language.Fixpoint.Types.Names as F-import qualified Language.Fixpoint.Types.Sorts as F-import qualified Language.Fixpoint.Types.Spans as F-import qualified Language.Fixpoint.Types.Refinements as F--- import qualified Language.Fixpoint.Types.Constraints as F---------------------------------------------------------------------------------------------------------------------- Human readable but robustly parseable SMT-LIB format pretty printer-------------------------------------------------------------------------------------------------------------------class ToHornSMT a where-  toHornSMT :: a -> P.Doc---instance ToHornSMT F.Symbol where-  toHornSMT s = F.pprint s----toHornWithBinders :: (ToHornSMT a, ToHornSMT t) => P.Doc -> [(F.Symbol, t)] -> a -> P.Doc-toHornWithBinders name xts p =  P.parens (name P.<+> toHornSMT xts P.<+> toHornSMT p)--instance ToHornSMT a => ToHornSMT (F.Symbol, a) where-  toHornSMT (x, t) = P.parens $ F.pprint x P.<+> toHornSMT t--instance ToHornSMT a => ToHornSMT [a] where-  toHornSMT = toHornMany . fmap toHornSMT--toHornMany :: [P.Doc] -> P.Doc-toHornMany = P.parens . P.sep--toHornAnd :: (a -> P.Doc) -> [a] -> P.Doc-toHornAnd f xs = P.parens (P.vcat ("and" : (P.nest 1 . f <$> xs)))---instance ToHornSMT F.DataDecl where-  toHornSMT (F.DDecl tc n ctors) =-    P.parens $ P.vcat [-      P.text "datatype" P.<+> P.parens (toHornSMT tc P.<+> P.int n)-    , P.parens (P.vcat (toHornSMT <$> ctors))-    ]--instance ToHornSMT F.FTycon where-  toHornSMT c-    | c == F.listFTyCon = "list"-    | otherwise         = toHornSMT (F.symbol c)--instance ToHornSMT a => ToHornSMT (F.Located a) where-  toHornSMT = toHornSMT . F.val--instance ToHornSMT F.DataCtor where-  toHornSMT (F.DCtor x flds) = P.parens (toHornSMT x P.<+> toHornSMT flds)--instance ToHornSMT F.DataField where-  toHornSMT (F.DField x t) = toHornSMT (F.val x, t)--instance ToHornSMT F.Sort where-  toHornSMT = toHornSort--toHornSort :: F.Sort -> P.Doc-toHornSort (F.FVar i)     = "@" P.<-> P.parens (P.int i)-toHornSort F.FInt         = "Int"-toHornSort F.FReal        = "Real"-toHornSort F.FFrac        = "Frac"-toHornSort (F.FObj x)     = toHornSMT x -- P.parens ("obj" P.<+> toHornSMT x)-toHornSort F.FNum         = "num"-toHornSort t@(F.FAbs _ _) = toHornAbsApp t-toHornSort t@(F.FFunc _ _)= toHornAbsApp t-toHornSort (F.FTC c)      = toHornSMT c-toHornSort t@(F.FApp _ _) = toHornFApp (F.unFApp t)-toHornSort (F.FNatNum x)  = P.integer x--toHornAbsApp :: F.Sort -> P.Doc-toHornAbsApp (F.functionSort -> Just (vs, ss, s)) = P.parens ("func" P.<+> P.int (length vs) P.<+> toHornSMT ss P.<+> toHornSMT s )-toHornAbsApp _                                    = error "Unexpected nothing function sort"--toHornFApp     :: [F.Sort] -> P.Doc-toHornFApp [t] = toHornSMT t-toHornFApp ts  = toHornSMT ts--instance ToHornSMT F.Subst where-  toHornSMT (F.Su m) = toHornSMT (Misc.hashMapToAscList m)--instance ToHornSMT (F.KVarSubst F.Symbol F.Symbol) where-  toHornSMT = toHornSMT . Misc.hashMapToAscList . F.fromKVarSubst--instance ToHornSMT F.KVar where-  toHornSMT (F.KV k) = "$" P.<-> toHornSMT k--instance ToHornSMT F.Expr where-  toHornSMT = toHornExpr--toHornExpr :: F.Expr -> P.Doc-toHornExpr (F.ESym c)        = F.pprint c-toHornExpr (F.ECon c)        = F.pprint c-toHornExpr (F.EVar s)        = toHornSMT s-toHornExpr (F.ENeg e)        = P.parens ("-" P.<+> toHornExpr e)-toHornExpr (F.EApp e1 e2)    = toHornSMT [e1, e2]-toHornExpr (F.EBin o e1 e2)  = toHornOp   (F.toFix o) [e1, e2]-toHornExpr (F.ELet x e1 e2)  = toHornMany ["let", toHornSMT [(x, e1)], toHornSMT e2]-toHornExpr (F.EIte e1 e2 e3) = toHornOp "if"  [e1, e2, e3]-toHornExpr (F.ECst e t)      = toHornMany ["cast", toHornSMT e, toHornSMT t]-toHornExpr (F.PNot p)        = toHornOp "not"  [p]-toHornExpr (F.PImp e1 e2)    = toHornOp "=>"   [e1, e2]-toHornExpr (F.PIff e1 e2)    = toHornOp "<=>"  [e1, e2]-toHornExpr e@F.PTrue         = F.pprint e-toHornExpr e@F.PFalse        = F.pprint e-toHornExpr (F.PAnd es)       = toHornOp "and" es-toHornExpr (F.POr  es)       = toHornOp "or"  es-toHornExpr (F.PAtom r e1 e2) = toHornOp (F.toFix r) [e1, e2]-toHornExpr (F.PAll xts p)    = toHornMany ["forall", toHornSMT xts, toHornSMT p]-toHornExpr (F.PExist xts p)  = toHornMany ["exists", toHornSMT xts, toHornSMT p]-toHornExpr (F.ELam b e)      = toHornMany ["lam", toHornSMT b, toHornSMT e]-toHornExpr (F.ECoerc a t e)  = toHornMany ["coerce", toHornSMT a, toHornSMT t, toHornSMT e]-toHornExpr (F.PKVar k _ su)    = toHornMany [toHornSMT k, toHornSMT su]-toHornExpr (F.ETApp e s)     = toHornMany ["ETApp" , toHornSMT e, toHornSMT s]-toHornExpr (F.ETAbs e s)     = toHornMany ["ETAbs" , toHornSMT e, toHornSMT s]--toHornOp :: ToHornSMT a => P.Doc -> [a] -> P.Doc-toHornOp op es = toHornMany (op : (toHornSMT <$> es))
src/Language/Fixpoint/Types/Solutions.hs view
@@ -7,13 +7,13 @@ {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE GADTs                      #-}+{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE PatternGuards              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DeriveAnyClass             #-} {-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE DeriveDataTypeable         #-}--{-# OPTIONS_GHC -Wno-name-shadowing     #-}+{-# LANGUAGE TupleSections              #-}  -- | This module contains the top-level SOLUTION data types, --   including various indices used for solving.@@ -21,38 +21,48 @@ module Language.Fixpoint.Types.Solutions (    -- * Solution tables-    Solution-  , Sol (..)+    Solution, GSolution+  , Sol (gMap, sEnv, sEbd, sxEnv)+  , updateGMap, updateGMapWithKey+  , sHyp+  , sScp   , CMap    -- * Solution elements-  , Hyp, Cube (..), QBind (..)+  , Hyp, Cube (..), QBind, GBind   , EQual (..)+  , EbindSol (..)    -- * Equal elements   , eQual   , trueEqual -  , qbExprs+  -- * Gradual Solution elements+  , qbToGb, gbToQbs, gbEquals, equalsGb, emptyGMap, qbExprs    -- * Solution Candidates (move to SolverMonad?)   , Cand +  -- * Constructor+  , fromList+   -- * Update   , update+  , updateEbind    -- * Lookup   , lookupQBind-  , lookup+  , lookup, glookup    -- * Manipulating QBind   , qb+  , qbPreds   , qbFilter-  , qbFilterM +  , gbFilterM    -- * Conversion for client-  , result+  , result, resultGradual    -- * "Fast" Solver (DEPRECATED as unsound)   , Index  (..)@@ -65,49 +75,73 @@ import           GHC.Generics import           Control.DeepSeq import           Data.Hashable-import qualified Data.Maybe                 as Mb+import qualified Data.Maybe                 as Mb  import qualified Data.HashMap.Strict        as M import qualified Data.List                  as L import           Data.Generics             (Data)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif+ import           Data.Typeable             (Typeable) import           Control.Monad (filterM) import           Language.Fixpoint.Misc import           Language.Fixpoint.Types.PrettyPrint-import           Language.Fixpoint.Types.Spans+import           Language.Fixpoint.Types.Spans  import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.Sorts+import           Language.Fixpoint.Types.Theories import           Language.Fixpoint.Types.Refinements import           Language.Fixpoint.Types.Environments import           Language.Fixpoint.Types.Constraints import           Language.Fixpoint.Types.Substitutions+import           Language.Fixpoint.SortCheck (elaborate) import           Text.PrettyPrint.HughesPJ.Compat  ----------------------------------------------------------------------------------- | Update Solution------ @update s kqs@ sets in @s@ each KVar in @kqs@ to the corresponding QBind.------ Yields a pair @(b, s')@ where @b@ is true if the mapping of any KVar was--- changed.------ Precondition: @kqs@ contains no duplicate KVars.----update :: Sol QBind -> [(KVar, QBind)] -> (Bool, Sol QBind)+-- | Update Solution ----------------------------------------------------------- ---------------------------------------------------------------------------------update s kqs = L.foldl' step (False, s) kqs+update :: Sol a QBind -> [KVar] -> [(KVar, EQual)] -> (Bool, Sol a QBind)+--------------------------------------------------------------------------------+update s ks kqs = {- tracepp msg -} (or bs, s')   where-    step :: (Bool, Sol QBind) -> (KVar, QBind) -> (Bool, Sol QBind)-    step (changed, s) (k, qs) = (changed || distinctSizes, updateK k qs s)-      where-        oldQs = lookupQBind s k-        distinctSizes = qbSize oldQs /= qbSize qs+    kqss        = groupKs ks kqs+    (bs, s')    = folds update1 s kqss+    -- msg      = printf "ks = %s, s = %s" (showpp ks) (showpp s) +folds   :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a)+folds f b = L.foldl' step ([], b)+  where+     step (cs, acc) x = (c:cs, x')+       where+         (c, x')      = f acc x++groupKs :: [KVar] -> [(KVar, EQual)] -> [(KVar, QBind)]+groupKs ks kqs = [ (k, QB eqs) | (k, eqs) <- M.toList $ groupBase m0 kqs ]+  where+    m0         = M.fromList $ (,[]) <$> ks++update1 :: Sol a QBind -> (KVar, QBind) -> (Bool, Sol a QBind)+update1 s (k, qs) = (change, updateK k qs s)+  where+    oldQs         = lookupQBind s k+    change        = qbSize oldQs /= qbSize qs++ -------------------------------------------------------------------------------- -- | The `Solution` data type -------------------------------------------------- ---------------------------------------------------------------------------------type Solution  = Sol QBind+type Solution  = Sol () QBind+type GSolution = Sol (((Symbol, Sort), Expr), GBind) QBind newtype QBind  = QB [EQual]   deriving (Show, Data, Typeable, Generic, Eq)+newtype GBind  = GB [[EQual]] deriving (Show, Data, Typeable, Generic) +emptyGMap :: GSolution -> GSolution+emptyGMap sol = mapGMap sol (\(x,_) -> (x, GB []))++updateGMapWithKey :: [(KVar, QBind)] -> GSolution -> GSolution+updateGMapWithKey kqs sol = sol {gMap =  foldl (\m (k, (QB eq)) -> M.adjust (\(x, GB eqs) -> (x, GB (if eq `elem` eqs then eqs else eq:eqs))) k m) (gMap sol) kqs }+ qb :: [EQual] -> QBind qb = QB @@ -117,51 +151,110 @@ qbExprs :: QBind -> [Expr] qbExprs (QB xs) = eqPred <$> xs +qbToGb :: QBind -> GBind+qbToGb (QB xs) = GB $ map (:[]) xs++gbToQbs :: GBind -> [QBind]+gbToQbs (GB [])  = [QB [trueEqual]]+gbToQbs (GB ess) = QB <$> ess++gbEquals :: GBind -> [[EQual]]+gbEquals (GB eqs) = eqs++equalsGb :: [[EQual]] -> GBind+equalsGb = GB++gbFilterM :: Monad m => ([EQual] -> m Bool) -> GBind -> m GBind+gbFilterM f (GB eqs) = GB <$> filterM f eqs+ qbSize :: QBind -> Int qbSize = length . qbEQuals  qbFilter :: (EQual -> Bool) -> QBind -> QBind qbFilter f (QB eqs) = QB (filter f eqs) -qbFilterM :: Monad m => (EQual -> m Bool) -> QBind -> m QBind-qbFilterM f (QB eqs) = QB <$> filterM f eqs- instance NFData QBind+instance NFData GBind  instance PPrint QBind where   pprintTidy k = pprintTidy k . qbEQuals  --------------------------------------------------------------------------------+-- | An `EbindSol` contains the relevant information for an existential-binder;+--   (See tests/pos/ebind-*.fq for examples.) This is either +--   1. the constraint whose HEAD is a singleton that defines the binder, OR +--   2. the solved out TERM that we should use in place of the ebind at USES.+--------------------------------------------------------------------------------+data EbindSol+  = EbDef [SimpC ()] Symbol -- ^ The constraint whose HEAD "defines" the Ebind+                             -- and the @Symbol@ for that EBind+  | EbSol Expr             -- ^ The solved out term that should be used at USES.+  | EbIncr                 -- ^ EBinds not to be solved for (because they're currently being solved for)+   deriving (Show, Generic, NFData)++instance PPrint EbindSol where +  pprintTidy k (EbDef i x) = "EbDef:" <+> pprintTidy k i <+> pprintTidy k x+  pprintTidy k (EbSol e)   = "EbSol:" <+> pprintTidy k e+  pprintTidy _ (EbIncr)    = "EbIncr"++--------------------------------------------------------------------------------+updateEbind :: Sol a b -> BindId -> Pred -> Sol a b +--------------------------------------------------------------------------------+updateEbind s i !e = case M.lookup i (sEbd s) of +  Nothing         -> errorstar $ "updateEBind: Unknown ebind " ++ show i+  Just (EbSol e0) -> errorstar $ "updateEBind: Re-assigning ebind " ++ show i ++ " with solution: " ++ show e0 +  Just _          -> s { sEbd = M.insert i (EbSol e) (sEbd s) }+    +-------------------------------------------------------------------------------- -- | A `Sol` contains the various indices needed to compute a solution, --   in particular, to compute `lhsPred` for any given constraint. ---------------------------------------------------------------------------------data Sol a = Sol-  { sMap :: !(M.HashMap KVar a)          -- ^ Actual solution (for cut kvar)+data Sol b a = Sol+  { sEnv :: !SymEnv                      -- ^ Environment used to elaborate solutions+  , sMap :: !(M.HashMap KVar a)          -- ^ Actual solution (for cut kvar)+  , gMap :: !(M.HashMap KVar b)          -- ^ Solution for gradual variables   , sHyp :: !(M.HashMap KVar Hyp)        -- ^ Defining cubes  (for non-cut kvar)-  , sScp :: !(M.HashMap KVar IBindEnv)   -- ^ Set of binders which are in scope for every-                                         -- occurrence of the kvar+  , sScp :: !(M.HashMap KVar IBindEnv)   -- ^ Set of allowed binders for kvar+  , sEbd :: !(M.HashMap BindId EbindSol) -- ^ EbindSol for each existential binder+  , sxEnv :: !(SEnv (BindId, Sort))      --   TODO: merge with sEnv? used for sorts of ebinds to solve ebinds in lhsPred   } deriving (Generic) -deriving instance NFData a => NFData (Sol a)+deriving instance (NFData b, NFData a) => NFData (Sol b a) -instance Semigroup (Sol a) where-  s1 <> s2 = Sol { sMap  = sMap s1  <> sMap s2-                 , sHyp  = sHyp s1  <> sHyp s2-                 , sScp  = sScp s1  <> sScp s2+updateGMap :: Sol b a -> M.HashMap KVar b -> Sol b a+updateGMap sol gmap = sol {gMap = gmap}++mapGMap :: Sol b a -> (b -> b) -> Sol b a+mapGMap sol f = sol {gMap = M.map f (gMap sol)}++instance Semigroup (Sol a b) where+  s1 <> s2 = Sol { sEnv  = (sEnv s1)  <> (sEnv s2)+                 , sMap  = (sMap s1)  <> (sMap s2)+                 , gMap  = (gMap s1)  <> (gMap s2)+                 , sHyp  = (sHyp s1)  <> (sHyp s2)+                 , sScp  = (sScp s1)  <> (sScp s2)+                 , sEbd  = (sEbd s1)  <> (sEbd s2) +                 , sxEnv = (sxEnv s1) <> (sxEnv s2)                   } -instance Monoid (Sol a) where-  mempty = Sol { sMap = mempty-               , sHyp = mempty-               , sScp = mempty+instance Monoid (Sol a b) where+  mempty = Sol { sEnv = mempty +               , sMap = mempty +               , gMap = mempty +               , sHyp = mempty +               , sScp = mempty +               , sEbd = mempty+               , sxEnv = mempty                }   mappend = (<>) -instance Functor Sol where-  fmap f (Sol s m1 m2) = Sol (f <$> s) m1 m2+instance Functor (Sol a) where+  fmap f (Sol e s m1 m2 m3 m4 m5) = Sol e (f <$> s) m1 m2 m3 m4 m5 -instance PPrint a => PPrint (Sol a) where-  pprintTidy k s = vcat [ "sMap :=" <+> pprintTidy k (sMap s) ]+instance (PPrint a, PPrint b) => PPrint (Sol a b) where+  pprintTidy k s = vcat [ "sMap :=" <+> pprintTidy k (sMap s)+                        , "sEbd :=" <+> pprintTidy k (sEbd s) +                        ]  -------------------------------------------------------------------------------- -- | A `Cube` is a single constraint defining a KVar ---------------------------@@ -181,22 +274,77 @@ instance Show Cube where   show = showpp ---------------------------------------------------------------------------------result :: Sol QBind -> M.HashMap KVar Expr+result :: Sol a QBind -> M.HashMap KVar Expr ---------------------------------------------------------------------------------result s = pAnd . fmap eqPred . qbEQuals <$> sMap s+result s = sMap $ (pAnd . fmap eqPred . qbEQuals) <$> s + --------------------------------------------------------------------------------+resultGradual :: GSolution -> M.HashMap KVar (Expr, [Expr])+--------------------------------------------------------------------------------+resultGradual s = fmap go' (gMap s)+  where+    go' ((_,e), GB eqss)+     = (e, [PAnd $ fmap eqPred eqs | eqs <- eqss])+++--------------------------------------------------------------------------------+-- | Create a Solution ---------------------------------------------------------+--------------------------------------------------------------------------------+fromList :: SymEnv +         -> [(KVar, a)] +         -> [(KVar, b)] +         -> [(KVar, Hyp)] +         -> M.HashMap KVar IBindEnv +         -> [(BindId, EbindSol)]+         -> SEnv (BindId, Sort)+         -> Sol a b+fromList env kGs kXs kYs z ebs xbs+        = Sol env kXm kGm kYm z ebm xbs+  where+    kXm = M.fromList kXs+    kYm = M.fromList kYs+    kGm = M.fromList kGs+    ebm = M.fromList ebs++--------------------------------------------------------------------------------+qbPreds :: String -> Sol a QBind -> Subst -> QBind -> [(Pred, EQual)]+--------------------------------------------------------------------------------+qbPreds msg s su (QB eqs) = [ (elabPred eq, eq) | eq <- eqs ]+  where+    elabPred eq           = elaborate (atLoc eq $ "qbPreds:" ++ msg) env +                          . subst su +                          . eqPred +                          $ eq+    env                   = sEnv s++-------------------------------------------------------------------------------- -- | Read / Write Solution at KVar --------------------------------------------- ---------------------------------------------------------------------------------lookupQBind :: Sol QBind -> KVar -> QBind+lookupQBind :: Sol a QBind -> KVar -> QBind -------------------------------------------------------------------------------- lookupQBind s k = {- tracepp _msg $ -} Mb.fromMaybe (QB []) (lookupElab s k)   where     _msg        = "lookupQB: k = " ++ show k  ---------------------------------------------------------------------------------lookup :: Sol QBind -> KVar -> Either Hyp QBind+glookup :: GSolution -> KVar -> Either Hyp (Either QBind (((Symbol, Sort), Expr), GBind)) --------------------------------------------------------------------------------+glookup s k+  | Just gbs <- M.lookup k (gMap s)+  = Right (Right gbs)+  | Just cs  <- M.lookup k (sHyp s) -- non-cut variable, return its cubes+  = Left cs+  | Just eqs <- lookupElab s k+  = Right (Left eqs)                 -- TODO: don't initialize kvars that have a hyp solution+  | otherwise+  = errorstar $ "solLookup: Unknown kvar " ++ show k++++--------------------------------------------------------------------------------+lookup :: Sol a QBind -> KVar -> Either Hyp QBind+-------------------------------------------------------------------------------- lookup s k   | Just cs  <- M.lookup k (sHyp s) -- non-cut variable, return its cubes   = Left cs@@ -205,11 +353,11 @@   | otherwise   = errorstar $ "solLookup: Unknown kvar " ++ show k -lookupElab :: Sol QBind -> KVar -> Maybe QBind+lookupElab :: Sol b QBind -> KVar -> Maybe QBind lookupElab s k = M.lookup k (sMap s)  ---------------------------------------------------------------------------------updateK :: KVar -> a -> Sol a -> Sol a+updateK :: KVar -> a -> Sol b a -> Sol b a -------------------------------------------------------------------------------- updateK k qs s = s { sMap = M.insert k qs (sMap s) --                 , sBot = M.delete k    (sBot s)@@ -227,31 +375,28 @@ -------------------------------------------------------------------------------- data EQual = EQL   { eqQual :: !Qualifier-  , eqPred  :: !Expr      -- ^ predicate obtained by instantiating the qualifier-  , _eqArgs :: ![Expr]    -- ^ actual arguments used to instantiate the qualifier+  , eqPred  :: !Expr+  , _eqArgs :: ![Expr]   } deriving (Eq, Show, Data, Typeable, Generic) -instance Loc EQual where-  srcSpan = srcSpan . eqQual+instance Loc EQual where +  srcSpan = srcSpan . eqQual   trueEqual :: EQual-trueEqual = EQL trueQual PTrue []+trueEqual = EQL trueQual mempty []  instance PPrint EQual where   pprintTidy k = pprintTidy k . eqPred  instance NFData EQual --- | @eQual q xs ls@ instantiates @q@ with variable arguments @xs@ and literal arguments @ls@-eQual :: Qualifier -> [Symbol] -> [Constant] -> EQual-eQual q xs ls = {- tracepp "eQual" $ -} EQL q p es+{- EQL :: q:_ -> p:_ -> ListX F.Expr {q_params q} -> _ @-}+eQual :: Qualifier -> [Symbol] -> EQual+eQual q xs = {- tracepp "eQual" $ -} EQL q p es   where     p      = subst su $  qBody q-    su     = mkSubst  $  safeZip "eQual" qxs (reverse es)-    (es, _, _) = L.foldl' go ([], xs, ls) (qParams q)-    go (acc, x:xs', cs   ) qp | qpPat qp /= PatLit = (eVar x : acc, xs', cs)-    go (acc, xs',   c:cs') qp | qpPat qp == PatLit = (ECon c : acc, xs', cs')-    go _                   _                       = error "eQual: mismatched params"+    su     = mkSubst  $  safeZip "eQual" qxs es+    es     = eVar    <$> xs     qxs    = qpSym   <$> qParams q  --------------------------------------------------------------------------------
src/Language/Fixpoint/Types/Sorts.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections              #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE LambdaCase                 #-}@@ -10,14 +11,13 @@ {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE GADTs                      #-}-{-# LANGUAGE ViewPatterns               #-} -{-# OPTIONS_GHC -Wno-name-shadowing     #-}-{-# LANGUAGE DeriveAnyClass #-}- -- | This module contains the data types, operations and --   serialization functions for representing Fixpoint's---   Horn and well-formedness constraints.+--   implication (i.e. subtyping) and well-formedness+--   constraints in Haskell. The actual constraint+--   solving is done by the `fixpoint.native` which+--   is written in Ocaml.  module Language.Fixpoint.Types.Sorts ( @@ -31,19 +31,14 @@   , boolFTyCon   , realFTyCon   , numFTyCon-  , fracFTyCon   , strFTyCon   , setFTyCon   , mapFTyCon -- TODO: hide these-  , ffldFTyCon   , mapFVar+   , basicSorts, intSort, realSort, boolSort, strSort, funcSort-  -- , bitVec32Sort, bitVec64Sort-  , setSort, bitVecSort, bagSort-  , arraySort-  , finfieldSort-  , sizedBitVecSort-  , mapSort, charSort+  , setSort, bitVecSort, mapSort, charSort+   , listFTyCon   , isListTC   , sizeBv@@ -60,7 +55,6 @@    , mkSortSubst   , sortSubst-  , SortSubst   , functionSort   , mkFFunc   , bkFFunc@@ -68,9 +62,8 @@   , mkPoly   , sortSymbols   , substSort-  , matchSortsTyVars -  , isBool, isNumeric, isReal, isString, isSet, isMap, isBag, isArray, isFinfield, isPolyInst+  , isNumeric, isReal, isString, isPolyInst    -- * User-defined ADTs   , DataField (..)@@ -80,36 +73,30 @@    -- * Embedding Source types as Sorts   , TCEmb, TCArgs (..)-  , tceLookup-  , tceFromList+  , tceLookup +  , tceFromList    , tceToList-  , tceMember+  , tceMember    , tceInsert   , tceInsertWith   , tceMap--  -- * Sort coercion for SMT theory encoding-  , coerceMapToArray-  , coerceSetBagToArray-  , coerceDataDecl   ) where  import qualified Data.Store as S import           Data.Generics             (Data) import           Data.Typeable             (Typeable) import           GHC.Generics              (Generic)-import           Data.Aeson-import           Data.Bifunctor (first) +#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif+ import           Data.Hashable import           Data.HashSet (HashSet) import qualified Data.HashSet as HashSet-#if !MIN_VERSION_base(4,20,0) import           Data.List                 (foldl')-#endif import           Control.DeepSeq import           Data.Maybe                (fromMaybe)-import           Language.Fixpoint.Types.Config (ElabFlags, elabSetBag) import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Spans@@ -118,9 +105,8 @@ import qualified Data.HashMap.Strict       as M import qualified Data.List                 as L import qualified Data.Binary as B-import Text.Read (readMaybe) -data FTycon   = TC LocSymbol TCInfo deriving (Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+data FTycon   = TC LocSymbol TCInfo deriving (Ord, Show, Data, Typeable, Generic)  -- instance Show FTycon where --   show (TC s _) = show (val s)@@ -132,7 +118,7 @@   (TC s _) == (TC s' _) = val s == val s'  data TCInfo = TCInfo { tc_isNum :: Bool, tc_isReal :: Bool, tc_isString :: Bool }-  deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+  deriving (Eq, Ord, Show, Data, Typeable, Generic)  mappendFTC :: FTycon -> FTycon -> FTycon mappendFTC (TC x i1) (TC _ i2) = TC x (mappend i1 i2)@@ -155,21 +141,18 @@ defRealInfo = False defStrInfo  = False -charFTyCon, intFTyCon, boolFTyCon, realFTyCon, funcFTyCon, numFTyCon, fracFTyCon :: FTycon-strFTyCon, listFTyCon, mapFTyCon, bagFTyCon, setFTyCon, ffldFTyCon :: FTycon-intFTyCon  = TC (dummyLoc "int"       ) numTcInfo-boolFTyCon = TC (dummyLoc boolLConName) defTcInfo-realFTyCon = TC (dummyLoc "real"      ) realTcInfo-numFTyCon  = TC (dummyLoc "num"       ) numTcInfo-fracFTyCon = TC (dummyLoc "frac"      ) realTcInfo-funcFTyCon = TC (dummyLoc "function"  ) defTcInfo-strFTyCon  = TC (dummyLoc strConName  ) strTcInfo-listFTyCon = TC (dummyLoc listConName ) defTcInfo-charFTyCon = TC (dummyLoc charConName ) defTcInfo-setFTyCon  = TC (dummyLoc setConName  ) defTcInfo-mapFTyCon  = TC (dummyLoc mapConName  ) defTcInfo-bagFTyCon  = TC (dummyLoc bagConName  ) defTcInfo-ffldFTyCon = TC (dummyLoc ffldConName ) defTcInfo+charFTyCon, intFTyCon, boolFTyCon, realFTyCon, funcFTyCon, numFTyCon :: FTycon+strFTyCon, listFTyCon, mapFTyCon, setFTyCon :: FTycon+intFTyCon  = TC (dummyLoc "int"      ) numTcInfo+boolFTyCon = TC (dummyLoc "bool"     ) defTcInfo+realFTyCon = TC (dummyLoc "real"     ) realTcInfo+numFTyCon  = TC (dummyLoc "num"      ) numTcInfo+funcFTyCon = TC (dummyLoc "function" ) defTcInfo+strFTyCon  = TC (dummyLoc strConName ) strTcInfo+listFTyCon = TC (dummyLoc listConName) defTcInfo+charFTyCon = TC (dummyLoc charConName) defTcInfo+setFTyCon  = TC (dummyLoc setConName ) defTcInfo+mapFTyCon  = TC (dummyLoc mapConName ) defTcInfo  isListConName :: LocSymbol -> Bool isListConName x = c == listConName || c == listLConName --"List"@@ -179,51 +162,13 @@ isListTC :: FTycon -> Bool isListTC (TC z _) = isListConName z -isSetConName :: LocSymbol -> Bool-isSetConName x = c == setConName-  where-    c           = val x--isSetTC :: FTycon -> Bool-isSetTC (TC z _) = isSetConName z--isMapConName :: LocSymbol -> Bool-isMapConName x = c == mapConName-  where-    c           = val x--isMapTC :: FTycon -> Bool-isMapTC (TC z _) = isMapConName z--isBagConName :: LocSymbol -> Bool-isBagConName x = c == bagConName-  where-    c           = val x--isBagTC :: FTycon -> Bool-isBagTC (TC z _) = isBagConName z--isArrayConName :: LocSymbol -> Bool-isArrayConName x = c == arrayConName-  where-    c           = val x--isArrayTC :: FTycon -> Bool-isArrayTC (TC z _) = isArrayConName z--isFinfieldConName :: LocSymbol -> Bool-isFinfieldConName x = c == ffldConName-  where-    c           = val x--isFinfieldTC :: FTycon -> Bool-isFinfieldTC (TC z _) = isFinfieldConName z- sizeBv :: FTycon -> Maybe Int-sizeBv tc = do-  let s = val $ fTyconSymbol tc-  size <- stripPrefix sizeName s-  readMaybe $ symbolString size+sizeBv tc+  | s == size32Name = Just 32+  | s == size64Name = Just 64+  | otherwise       = Nothing+  where+    s               = val $ fTyconSymbol tc  fTyconSymbol :: FTycon -> Located Symbol fTyconSymbol (TC s _) = s@@ -271,7 +216,6 @@ sortFTycon :: Sort -> Maybe FTycon sortFTycon FInt    = Just intFTyCon sortFTycon FReal   = Just realFTyCon-sortFTycon FFrac   = Just fracFTyCon sortFTycon FNum    = Just numFTyCon sortFTycon (FTC c) = Just c sortFTycon _       = Nothing@@ -290,25 +234,24 @@     go vs ss t             = (reverse vs, reverse ss, t)  -sortAbs :: Sort -> Int-sortAbs (FAbs i s)    = max i (sortAbs s)-sortAbs (FFunc s1 s2) = max (sortAbs s1) (sortAbs s2)+sortAbs :: Sort -> Int +sortAbs (FAbs i s)    = max i (sortAbs s) +sortAbs (FFunc s1 s2) = max (sortAbs s1) (sortAbs s2)  sortAbs (FApp  s1 s2) = max (sortAbs s1) (sortAbs s2)-sortAbs _             = -1+sortAbs _             = -1   -mapFVar :: (Int -> Int) -> Sort -> Sort-mapFVar f = go+mapFVar :: (Int -> Int) -> Sort -> Sort +mapFVar f = go    where go (FVar i)      = FVar (f i)         go (FAbs i t)    = FAbs (f i) (go t)         go (FFunc t1 t2) = FFunc (go t1) (go t2)         go (FApp t1 t2)  = FApp (go t1) (go t2)-        go t@(FObj _)    = t-        go t@(FTC _)     = t-        go t@FInt        = t-        go t@FReal       = t-        go t@FNum        = t-        go t@FFrac       = t-        go t@(FNatNum _) = t+        go t@(FObj _)    = t  +        go t@(FTC _)     = t  +        go t@FInt        = t  +        go t@FReal       = t  +        go t@FNum        = t  +        go t@FFrac       = t    -------------------------------------------------------------------------------- -- | Sorts ---------------------------------------------------------------------@@ -317,17 +260,13 @@           | FReal           | FNum                 -- ^ numeric kind for Num tyvars           | FFrac                -- ^ numeric kind for Fractional tyvars-          | FObj    !Symbol      -- ^ uninterpreted type-          | FVar    !Int         -- ^ fixpoint type variable-          | FFunc   !Sort !Sort  -- ^ function-          | FAbs    !Int !Sort   -- ^ type-abstraction-          | FTC     !FTycon-          | FApp    !Sort !Sort  -- ^ constructed type-          | FNatNum !Integer     -- ^ typelevel natural numeral-            deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)--instance PPrint Sort where-  pprintTidy _ = toFix+          | FObj  !Symbol        -- ^ uninterpreted type+          | FVar  !Int           -- ^ fixpoint type variable+          | FFunc !Sort !Sort    -- ^ function+          | FAbs  !Int !Sort     -- ^ type-abstraction+          | FTC   !FTycon+          | FApp  !Sort !Sort    -- ^ constructed type+            deriving (Eq, Ord, Show, Data, Typeable, Generic)  sortSymbols :: Sort -> HashSet Symbol sortSymbols = \case@@ -345,40 +284,21 @@   FAbs i t -> FAbs i (substSort f t)   t -> t --- | @matchSortsTyVars tvs wfSort useSiteSort@ structurally matches two sorts and--- extracts a mapping from type variable symbols (in @tvs@) to their--- instantiation at the use site. For example:------ > matchSortsTyVars ["a"] (FApp listTC (FObj "a")) (FApp listTC (FObj "b"))--- >   == HashMap.fromList [("a", FObj "b")]-matchSortsTyVars :: [Symbol] -> Sort -> Sort -> M.HashMap Symbol Sort-matchSortsTyVars tvs wfSort useSiteSort-  | null tvs  = M.empty-  | otherwise = go M.empty wfSort useSiteSort-  where-    tvSet = HashSet.fromList tvs-    go acc (FObj s) t-      | HashSet.member s tvSet = if FObj s /= t then M.insert s t acc else acc-    go acc (FFunc a1 a2) (FFunc b1 b2) = go (go acc a1 b1) a2 b2-    go acc (FApp a1 a2) (FApp b1 b2) = go (go acc a1 b1) a2 b2-    go acc (FAbs _ a) (FAbs _ b) = go acc a b-    go acc _ _ = acc- data DataField = DField   { dfName :: !LocSymbol          -- ^ Field Name   , dfSort :: !Sort               -- ^ Field Sort-  } deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+  } deriving (Eq, Ord, Show, Data, Typeable, Generic)  data DataCtor = DCtor   { dcName   :: !LocSymbol        -- ^ Ctor Name   , dcFields :: ![DataField]      -- ^ Ctor Fields-  } deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+  } deriving (Eq, Ord, Show, Data, Typeable, Generic)  data DataDecl = DDecl   { ddTyCon :: !FTycon            -- ^ Name of defined datatype   , ddVars  :: !Int               -- ^ Number of type variables   , ddCtors :: [DataCtor]         -- ^ Datatype Ctors. Invariant: type variables bound in ctors are greater than ddVars-  } deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+  } deriving (Eq, Ord, Show, Data, Typeable, Generic)  instance Loc DataDecl where     srcSpan (DDecl ty _ _) = srcSpan ty@@ -397,7 +317,7 @@ muSort dds = mapSortDataDecl tx <$> dds   where     selfs = [(fTyconSelfSort c n, fTyconSort c) | DDecl c n _ <- dds]-    tx t  = fromMaybe t $ L.lookup t selfs+    tx t  = fromMaybe t $ L.lookup t selfs       mapSortDataDecl f  dd = dd { ddCtors  = mapSortDataCTor f  <$> ddCtors  dd }     mapSortDataCTor f  ct = ct { dcFields = mapSortDataField f <$> dcFields ct }@@ -414,10 +334,6 @@ isFunction (FFunc _ _) = True isFunction _           = False -isBool :: Sort -> Bool-isBool (FTC (TC c _)) = val c == boolLConName-isBool _              = False- isNumeric :: Sort -> Bool isNumeric FInt           = True isNumeric FReal          = True@@ -433,9 +349,10 @@ isReal (FAbs _ s)     = isReal s isReal _              = False + isString :: Sort -> Bool isString (FApp l c)     = (isList l && isChar c) || isString l-isString (FTC (TC c i)) = val c == strConName || tc_isString i+isString (FTC (TC c i)) = (val c == strConName || tc_isString i) isString (FAbs _ s)     = isString s isString _              = False @@ -443,26 +360,6 @@ isList (FTC c) = isListTC c isList _       = False -isSet :: Sort -> Bool-isSet (FTC c) = isSetTC c-isSet _       = False--isMap :: Sort -> Bool-isMap (FTC c) = isMapTC c-isMap _       = False--isBag :: Sort -> Bool-isBag (FTC c) = isBagTC c-isBag _       = False--isArray :: Sort -> Bool-isArray (FTC c) = isArrayTC c-isArray _       = False--isFinfield :: Sort -> Bool-isFinfield (FTC c) = isFinfieldTC c-isFinfield _       = False- isChar :: Sort -> Bool isChar (FTC c) = c == charFTyCon isChar _       = False@@ -477,7 +374,7 @@     go (i:is) ss = FAbs  i $ go is ss     go _ _       = error "cannot happen" -   -- foldl' (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1]+   -- foldl (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1]  bkFFunc :: Sort -> Maybe (Int, [Sort]) bkFFunc t    = (maximum (0 : as),) <$> bkFun t'@@ -502,8 +399,8 @@ isPoly FAbs {} = True isPoly _       = False -mkPoly :: Int -> Sort -> Sort-mkPoly i s = foldl' (flip FAbs) s [0..i]+mkPoly :: Int -> Sort -> Sort +mkPoly i s = foldl (flip FAbs) s [0..i]    instance Hashable FTycon where@@ -530,15 +427,13 @@ toFixSort t@(FFunc _ _)= toFixAbsApp t toFixSort (FTC c)      = toFix c toFixSort t@(FApp _ _) = toFixFApp (unFApp t)-toFixSort (FNatNum x)  = toFix x  toFixAbsApp :: Sort -> Doc-toFixAbsApp (functionSort -> Just (vs, ss, s)) =-  text "func" <-> parens (toFix n <+> text "," <+> toFix ts)+toFixAbsApp t = text "func" <-> parens (toFix n <+> text "," <+> toFix ts)   where+    Just (vs, ss, s) = functionSort t     n                = length vs     ts               = ss ++ [s]-toFixAbsApp _ = error "Unexpected nothing function sort"  toFixFApp            :: ListNE Sort -> Doc toFixFApp [t]        = toFixSort t@@ -558,7 +453,7 @@ instance Fixpoint DataDecl where   toFix (DDecl tc n ctors) = vcat ([header] ++ body ++ [footer])     where-      header               = toFix tc <+> toFix n <+> text "= ["+      header               = {- text "data" <+> -} toFix tc <+> toFix n <+> text "= ["       body                 = [nest 2 (text "|" <+> toFix ct) | ct <- ctors]       footer               = text "]" @@ -587,35 +482,14 @@ funcSort = fTyconSort funcFTyCon  setSort :: Sort -> Sort-setSort = FApp (FTC setFTyCon)---- bitVecSort :: Sort -> Sort--- bitVecSort = FApp (FTC $ symbolFTycon' bitVecName)---- bitVec32Sort :: Sort--- bitVec32Sort = bitVecSort (FTC (symbolFTycon' size32Name))------ bitVec64Sort :: Sort--- bitVec64Sort = bitVecSort (FTC (symbolFTycon' size64Name))--bitVecSort :: Int -> Sort-bitVecSort i = FApp (FTC $ symbolFTycon' bitVecName) (FVar i)--sizedBitVecSort :: Symbol -> Sort-sizedBitVecSort i = FApp (FTC $ symbolFTycon' bitVecName) (FTC $ symbolFTycon' i)+setSort    = FApp (FTC setFTyCon) -bagSort :: Sort -> Sort-bagSort = FApp (FTC bagFTyCon)+bitVecSort :: Sort+bitVecSort = FApp (FTC $ symbolFTycon' bitVecName) (FTC $ symbolFTycon' size32Name)  mapSort :: Sort -> Sort -> Sort mapSort = FApp . FApp (FTC (symbolFTycon' mapConName)) -arraySort :: Sort -> Sort -> Sort-arraySort = FApp . FApp (FTC (symbolFTycon' arrayConName))--finfieldSort :: Sort -> Sort-finfieldSort = FApp (FTC ffldFTyCon)- symbolFTycon' :: Symbol -> FTycon symbolFTycon' = symbolFTycon . dummyLoc @@ -623,14 +497,13 @@ fTyconSort c   | c == intFTyCon  = FInt   | c == realFTyCon = FReal-  | c == fracFTyCon = FFrac   | c == numFTyCon  = FNum   | otherwise       = FTC c  basicSorts :: [Sort]-basicSorts = [FInt, boolSort]+basicSorts = [FInt, boolSort]  -type SortSubst = M.HashMap Symbol Sort+type SortSubst = M.HashMap Symbol Sort   mkSortSubst :: [(Symbol, Sort)] -> SortSubst mkSortSubst = M.fromList@@ -644,8 +517,8 @@ sortSubst θ (FAbs i t)    = FAbs i (sortSubst θ t) sortSubst _  t            = t --- instance (S.Store a) => S.Store (TCEmb a)-instance S.Store TCArgs+-- instance (S.Store a) => S.Store (TCEmb a) +instance S.Store TCArgs  instance S.Store FTycon instance S.Store TCInfo instance S.Store Sort@@ -658,13 +531,12 @@ instance B.Binary TCInfo instance B.Binary FTycon instance B.Binary Sort-instance (Eq a, Hashable a, B.Binary (M.HashMap a (Sort, TCArgs))) => B.Binary (TCEmb a)  instance NFData FTycon where   rnf (TC x i) = x `seq` i `seq` () -instance (NFData a) => NFData (TCEmb a)-instance NFData TCArgs+instance (NFData a) => NFData (TCEmb a) +instance NFData TCArgs  instance NFData TCInfo instance NFData Sort instance NFData DataField@@ -672,93 +544,69 @@ instance NFData DataDecl instance NFData Sub +instance Semigroup Sort where+  t1 <> t2+    | t1 == mempty  = t2+    | t2 == mempty  = t1+    | t1 == t2      = t1+    | otherwise     = errorstar $ "mappend-sort: conflicting sorts t1 =" ++ show t1 ++ " t2 = " ++ show t2++instance Monoid Sort where+  mempty  = FObj "any"+  mappend = (<>)+ ---------------------------------------------------------------------------------- | Embedding stuff as Sorts+-- | Embedding stuff as Sorts  --------------------------------------------------------------------------------newtype TCEmb a = TCE (M.HashMap a (Sort, TCArgs))-  deriving (Eq, Show, Data, Typeable, Generic)+newtype TCEmb a = TCE (M.HashMap a (Sort, TCArgs)) +  deriving (Eq, Show, Data, Typeable, Generic)   instance Hashable a => Hashable (TCEmb a)-instance PPrint a => PPrint (TCEmb a) where-  pprintTidy k = pprintTidy k . tceToList --data TCArgs = WithArgs | NoArgs-  deriving (Eq, Ord, Show, Data, Typeable, Generic)+data TCArgs = WithArgs | NoArgs +  deriving (Eq, Ord, Show, Data, Typeable, Generic)  -instance Hashable TCArgs-instance B.Binary TCArgs+instance Hashable TCArgs   tceInsertWith :: (Eq a, Hashable a) => (Sort -> Sort -> Sort) -> a -> Sort -> TCArgs -> TCEmb a -> TCEmb a tceInsertWith f k t a (TCE m) = TCE (M.insertWith ff k (t, a) m)-  where+  where      ff (t1, a1) (t2, a2)      = (f t1 t2, a1 <> a2) -instance Semigroup TCArgs where+instance Semigroup TCArgs where    NoArgs <> NoArgs = NoArgs   _      <> _      = WithArgs -instance Monoid TCArgs where-  mempty = NoArgs+instance Monoid TCArgs where +  mempty = NoArgs    mappend = (<>) -instance PPrint TCArgs where+instance PPrint TCArgs where    pprintTidy _ WithArgs = "*"   pprintTidy _ NoArgs   = ""  tceInsert :: (Eq a, Hashable a) => a -> Sort -> TCArgs -> TCEmb a -> TCEmb a tceInsert k t a (TCE m) = TCE (M.insert k (t, a) m) -tceLookup :: (Eq a, Hashable a) => a -> TCEmb a -> Maybe (Sort, TCArgs)+tceLookup :: (Eq a, Hashable a) => a -> TCEmb a -> Maybe (Sort, TCArgs)  tceLookup k (TCE m) = M.lookup k m -instance (Eq a, Hashable a) => Semigroup (TCEmb a) where+instance (Eq a, Hashable a) => Semigroup (TCEmb a) where    (TCE m1) <> (TCE m2) = TCE (m1 <> m2) -instance (Eq a, Hashable a) => Monoid (TCEmb a) where-  mempty  = TCE mempty+instance (Eq a, Hashable a) => Monoid (TCEmb a) where +  mempty  = TCE mempty    mappend = (<>)   tceMap :: (Eq b, Hashable b) => (a -> b) -> TCEmb a -> TCEmb b-tceMap f = tceFromList . fmap (first f) . tceToList+tceMap f = tceFromList . fmap (mapFst f) . tceToList   tceFromList :: (Eq a, Hashable a) => [(a, (Sort, TCArgs))] -> TCEmb a-tceFromList = TCE . M.fromList+tceFromList = TCE . M.fromList   tceToList :: TCEmb a -> [(a, (Sort, TCArgs))] tceToList (TCE m) = M.toList m -tceMember :: (Eq a, Hashable a) => a -> TCEmb a -> Bool+tceMember :: (Eq a, Hashable a) => a -> TCEmb a -> Bool  tceMember k (TCE m) = M.member k m------------------------------------------------------------------------------------ | Sort coercion for SMT theory encoding----------------------------------------------------------------------------------coerceMapToArray :: Sort -> Sort-coerceMapToArray (FFunc sf sa) = FFunc (coerceMapToArray sf) (coerceMapToArray sa)-coerceMapToArray (FAbs i sa)   = FAbs i (coerceMapToArray sa)-coerceMapToArray (FApp (FApp sf sa) sb)-  | isMap sf = arraySort (coerceMapToArray sa) (coerceMapToArray sb)-  | otherwise = FApp (FApp (coerceMapToArray sf) (coerceMapToArray sa)) (coerceMapToArray sb)-coerceMapToArray (FApp sf sa) = FApp (coerceMapToArray sf) (coerceMapToArray sa)-coerceMapToArray s = s--coerceSetBagToArray :: Sort -> Sort-coerceSetBagToArray (FFunc sf sa) = FFunc (coerceSetBagToArray sf) (coerceSetBagToArray sa)-coerceSetBagToArray (FAbs i sa)   = FAbs i (coerceSetBagToArray sa)-coerceSetBagToArray (FApp sf sa)-  | isSet sf = arraySort (coerceSetBagToArray sa) boolSort-  | isBag sf = arraySort (coerceSetBagToArray sa) intSort-  | otherwise = FApp (coerceSetBagToArray sf) (coerceSetBagToArray sa)-coerceSetBagToArray s = s--coerceDataField :: ElabFlags -> DataField -> DataField-coerceDataField ef (DField x t)  = DField x (((if elabSetBag ef then coerceSetBagToArray else id) . coerceMapToArray) t)--coerceDataCtor :: ElabFlags -> DataCtor -> DataCtor-coerceDataCtor ef (DCtor x flds) = DCtor x (coerceDataField ef <$> flds)--coerceDataDecl :: ElabFlags -> DataDecl -> DataDecl-coerceDataDecl ef (DDecl tc n ctors) = DDecl tc n (coerceDataCtor ef <$> ctors)
src/Language/Fixpoint/Types/Spans.hs view
@@ -4,9 +4,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables       #-} -{-# OPTIONS_GHC -Wno-orphans           #-}-{-# LANGUAGE DeriveAnyClass #-}- module Language.Fixpoint.Types.Spans (    -- * Concrete Location Type@@ -37,7 +34,7 @@    -- * Destructing spans   , sourcePosElts-  , srcLine+  , srcLine    ) where  -- import           Control.Exception@@ -57,7 +54,6 @@ import           Text.Printf import Data.Functor.Contravariant (Contravariant(contramap)) import qualified Data.Binary as B-import           Data.Aeson -- import           Debug.Trace  @@ -157,21 +153,16 @@ ppSourcePos :: SourcePos -> Doc ppSourcePos z = text (printf "%s:%d:%d" f l c)   where-    (f,l,c) = sourcePosElts z+    (f,l,c) = sourcePosElts $ z  instance Fixpoint SourcePos where   toFix = text . show  -data Located a = Loc-  { loc  :: !SourcePos -- ^ Start Position-  , locE :: !SourcePos -- ^ End Position-  , val  :: !a-  }-  deriving (Data, Typeable, Generic, ToJSON, FromJSON)--instance ToJSON SourcePos where-instance FromJSON SourcePos where+data Located a = Loc { loc  :: !SourcePos -- ^ Start Position+                     , locE :: !SourcePos -- ^ End Position+                     , val  :: !a+                     } deriving (Data, Typeable, Generic)  instance Loc (Located a) where   srcSpan (Loc l l' _) = SS l l'@@ -222,11 +213,6 @@  instance (B.Binary a) => B.Binary (Located a) --instance ToJSON Pos where--instance FromJSON Pos where- srcLine :: (Loc a) => a -> Pos srcLine = sourceLine . sp_start . srcSpan @@ -236,12 +222,9 @@  data SrcSpan = SS { sp_start :: !SourcePos                   , sp_stop  :: !SourcePos}-                 deriving (Eq, Ord, Show, Data, Typeable, Generic, ToJSON, FromJSON)+                 deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance NFData SrcSpan-instance S.Store SrcSpan instance Serialize SrcSpan-instance B.Binary SrcSpan  instance PPrint SrcSpan where   pprintTidy _ = ppSrcSpan@@ -263,13 +246,13 @@ instance Hashable SrcSpan where   hashWithSalt i z = hashWithSalt i (sp_start z, sp_stop z) -instance Loc SrcSpan where-  srcSpan x = x+instance Loc SrcSpan where +  srcSpan x = x   instance Loc () where   srcSpan _ = dummySpan -instance Loc SourcePos where+instance Loc SourcePos where    srcSpan l = SS l l  dummySpan :: SrcSpan
src/Language/Fixpoint/Types/Substitutions.hs view
@@ -1,42 +1,29 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}--{-# OPTIONS_GHC -Wno-orphans   #-}-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE CPP #-}  -- | This module contains the various instances for Subable, --   which (should) depend on the visitors, and hence cannot --   be in the same place as the @Term@ definitions.++{-# LANGUAGE FlexibleInstances #-} module Language.Fixpoint.Types.Substitutions (     mkSubst-  , mkKVarSubst-  , substFromKSubst-  , kSubstFromSubst-  , ksubst   , isEmptySubst   , substExcept   , substfExcept   , subst1Except-  , substSymbolsSet-  , Refreshable(..)-  , rapierSubstExpr   , targetSubstSyms   , filterSubst   , catSubst   , exprSymbolsSet-  , extendSubst-  , meetReft-  , pprReft   ) where -import           Data.List                 as List import           Data.Maybe-import           Data.Hashable             (Hashable) import qualified Data.HashMap.Strict       as M import qualified Data.HashSet              as S-import           Language.Fixpoint.Types.Binders+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif+ import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.Sorts@@ -45,102 +32,78 @@ import           Text.PrettyPrint.HughesPJ.Compat import           Text.Printf               (printf) -instance (Eq v, Hashable v) => Semigroup (SubstV v) where+instance Semigroup Subst where   (<>) = catSubst -instance (Eq v, Hashable v) => Monoid (SubstV v) where+instance Monoid Subst where   mempty  = emptySubst   mappend = (<>) -instance Semigroup (KVarSubst Symbol Symbol) where-  su1 <> su2 = kSubstFromSubst $ substFromKSubst su1 <> substFromKSubst su2--instance Monoid (KVarSubst Symbol Symbol) where-  mempty = kSubstFromSubst mempty-  mappend = (<>)--substFromKSubst :: Hashable v => KVarSubst v v -> SubstV v-substFromKSubst = Su . fromKVarSubst--kSubstFromSubst :: SubstV v -> KVarSubst v v-kSubstFromSubst (Su m) = toKVarSubst m--ksubst :: KVarSubst Symbol Symbol -> Expr -> Expr-ksubst = subst . substFromKSubst--filterSubst :: (v -> ExprBV v v -> Bool) -> SubstV v -> SubstV v+filterSubst :: (Symbol -> Expr -> Bool) -> Subst -> Subst filterSubst f (Su m) = Su (M.filterWithKey f m) -emptySubst :: SubstV v+emptySubst :: Subst emptySubst = Su M.empty -catSubst :: (Eq v, Hashable v) => SubstV v -> SubstV v -> SubstV v+catSubst :: Subst -> Subst -> Subst catSubst (Su s1) θ2@(Su s2) = Su $ M.union s1' s2   where     s1'                     = subst θ2 <$> s1 -mkSubst :: Hashable v => [(v, ExprBV v v)] -> SubstV v+mkSubst :: [(Symbol, Expr)] -> Subst mkSubst = Su . M.fromList . reverse . filter notTrivial   where     notTrivial (x, EVar y) = x /= y     notTrivial _           = True -mkKVarSubst :: [(Symbol, Expr)] -> KVarSubst Symbol Symbol-mkKVarSubst = kSubstFromSubst . mkSubst--isEmptySubst :: SubstV v -> Bool+isEmptySubst :: Subst -> Bool isEmptySubst (Su xes) = M.null xes -targetSubstSyms :: (Eq v, Hashable v) => SubstV v -> [v]+targetSubstSyms :: Subst -> [Symbol] targetSubstSyms (Su ms) = syms $ M.elems ms -substSymbolsSet :: (Eq v, Hashable v) => SubstV v -> S.HashSet v-substSymbolsSet (Su m) = S.unions $ map exprSymbolsSet (M.elems m) +   instance Subable () where   syms _      = []   subst _ ()  = ()   substf _ () = ()   substa _ () = () -instance (Subable a, Subable b, Variable a ~ Variable b) => Subable (a,b) where-  type Variable (a, b) = Variable a+instance (Subable a, Subable b) => Subable (a,b) where   syms  (x, y)   = syms x ++ syms y   subst su (x,y) = (subst su x, subst su y)   substf f (x,y) = (substf f x, substf f y)   substa f (x,y) = (substa f x, substa f y)  instance Subable a => Subable [a] where-  type Variable [a] = Variable a   syms   = concatMap syms   subst  = fmap . subst   substf = fmap . substf   substa = fmap . substa  instance Subable a => Subable (Maybe a) where-  type Variable (Maybe a) = Variable a   syms   = concatMap syms . maybeToList   subst  = fmap . subst   substf = fmap . substf   substa = fmap . substa -+  instance Subable a => Subable (M.HashMap k a) where-  type Variable (M.HashMap k a) = Variable a   syms   = syms . M.elems   subst  = M.map . subst   substf = M.map . substf   substa = M.map . substa -subst1Except :: Subable a => [Variable a] -> a -> (Variable a, ExprBV (Variable a) (Variable a)) -> a+subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a subst1Except xs z su@(x, _)   | x `elem` xs = z   | otherwise   = subst1 z su -substfExcept :: Eq v => (v -> ExprBV b v) -> [v] -> v -> ExprBV b v+substfExcept :: (Symbol -> Expr) -> [Symbol] -> Symbol -> Expr substfExcept f xs y = if y `elem` xs then EVar y else f y -substExcept  :: Eq v => SubstV v -> [v] -> SubstV v+substExcept  :: Subst -> [Symbol] -> Subst -- substExcept  (Su m) xs = Su (foldr M.delete m xs) substExcept (Su xes) xs = Su $ M.filterWithKey (const . not . (`elem` xs)) xes @@ -150,28 +113,25 @@   subst su x               = subSymbol (Just $ appSubst su x) x -- subSymbol (M.lookup x s) x   syms x                   = [x] -appSubst :: (Eq v, Hashable v) => SubstV v -> v -> ExprBV v v+appSubst :: Subst -> Symbol -> Expr appSubst (Su s) x = fromMaybe (EVar x) (M.lookup x s) -subSymbol :: (Ord v, Hashable v, Fixpoint v) => Maybe (ExprBV v v) -> v -> v+subSymbol :: Maybe Expr -> Symbol -> Symbol subSymbol (Just (EVar y)) _ = y subSymbol Nothing         x = x subSymbol a               b = errorstar (printf "Cannot substitute symbol %s with expression %s" (showFix b) (showFix a)) -captureAvoiding :: Eq v => v -> (v -> ExprBV b v) -> v -> ExprBV b v-captureAvoiding x f y = if y == x then EVar x else f y+substfLam :: (Symbol -> Expr) -> (Symbol, Sort) -> Expr -> Expr+substfLam f s@(x, _) e =  ELam s (substf (\y -> if y == x then EVar x else f y) e) -instance (Eq v, Hashable v) => Subable (ExprBV v v) where-  type Variable (ExprBV v v) = v+instance Subable Expr where   syms                     = exprSymbols   substa f                 = substf (EVar . f)-  substf :: (v -> ExprBV v v) -> ExprBV v v -> ExprBV v v   substf f (EApp s e)      = EApp (substf f s) (substf f e)-  substf f (ELam (x,t) e)  = ELam (x, t) (substf (captureAvoiding x f) e)+  substf f (ELam x e)      = substfLam f x e   substf f (ECoerc a t e)  = ECoerc a t (substf f e)   substf f (ENeg e)        = ENeg (substf f e)   substf f (EBin op e1 e2) = EBin op (substf f e1) (substf f e2)-  substf f (ELet x e1 e2)  = ELet x (substf f e1) (substf (captureAvoiding x f) e2)   substf f (EIte p e1 e2)  = EIte (substf f p) (substf f e1) (substf f e2)   substf f (ECst e so)     = ECst (substf f e) so   substf f (EVar x)        = f x@@ -181,172 +141,77 @@   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 f (PKVar k tsu su)    = PKVar k tsu (mapKVarSubst (substf f) su)-  substf _ (PAll _ _)      = errorstar "substf: FORALL"-  substf f (PExist xts e)  = PExist xts (substf f e)+  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  -  subst = go-    where-      -- The auxiliary go function skips the HasCallStack constraint on every-      -- recursive call. In case of error, the call stack only contains the-      -- point at which subst was first called.-      go su e0 = case e0 of-        EApp f e ->-          EApp (go su f) (go su e)-        ELam x e ->-          let su' = removeSubst su (fst x)-           in ELam x (go su' e)-        ELet x e1 e2 ->-          let su' = removeSubst su x-           in ELet x (go su e1) (go su' e2)-        ECoerc a t e ->-          ECoerc a t (go su e)-        ENeg e ->-          ENeg (go su e)-        EBin op e1 e2 ->-          EBin op (go su e1) (go su e2)-        EIte p e1 e2 ->-          EIte (go su p) (go su e1) (go su e2)-        ECst e so ->-          ECst (go su e) so-        EVar x ->-          appSubst su x-        PAnd ps ->-          PAnd $ map (go su) ps-        POr  ps ->-          POr  $ map (go su) ps-        PNot p ->-          PNot $ go su p-        PImp p1 p2 ->-          PImp (go su p1) (go su p2)-        PIff p1 p2 ->-          PIff (go su p1) (go su p2)-        PAtom r e1 e2 ->-          PAtom r (go su e1) (go su e2)-        PKVar k tsu su' ->-          PKVar k tsu (kSubstFromSubst $ substFromKSubst su' `catSubst` su)-        PAll bs p-          | disjointRange su' bs ->-            PAll bs $ go su' p-          | otherwise ->-            errorstar "subst: PAll (without disjoint binds)"-          where-            su' = substExcept su (map fst bs)--        PExist bs p-          | disjointRange su' bs ->-            PExist bs $ go su' p-          | otherwise ->-            errorstar "subst: EXISTS without disjoint binds"-          where-            su' = substExcept su (map fst bs)-        p ->-          p+  subst su (EApp f e)      = EApp (subst su f) (subst su e)+  subst su (ELam x e)      = ELam x (subst (removeSubst su (fst x)) e)+  subst su (ECoerc a t e)  = ECoerc a t (subst su e)+  subst su (ENeg e)        = ENeg (subst su e)+  subst su (EBin op e1 e2) = EBin op (subst su e1) (subst su e2)+  subst su (EIte p e1 e2)  = EIte (subst su p) (subst su e1) (subst su e2)+  subst su (ECst e so)     = ECst (subst su e) so+  subst su (EVar x)        = appSubst su x+  subst su (PAnd ps)       = PAnd $ map (subst su) ps+  subst su (POr  ps)       = POr  $ map (subst su) ps+  subst su (PNot p)        = PNot $ subst su p+  subst su (PImp p1 p2)    = PImp (subst su p1) (subst su p2)+  subst su (PIff p1 p2)    = PIff (subst su p1) (subst su p2)+  subst su (PAtom r e1 e2) = PAtom r (subst su e1) (subst su e2)+  subst su (PKVar k su')   = PKVar k $ su' `catSubst` su+  subst su (PGrad k su' i e) = PGrad k (su' `catSubst` su) i (subst su e)+  subst su (PAll bs p)+          | disjoint su bs = PAll bs $ subst su p --(substExcept su (fst <$> bs)) p+          | otherwise      = errorstar "subst: PAll (without disjoint binds)"+  subst su (PExist bs p)+          | disjoint su bs = PExist bs $ subst su p --(substExcept su (fst <$> bs)) p+          | otherwise      = errorstar ("subst: EXISTS (without disjoint binds)" ++ show (bs, su, p))+  subst _  p               = p -removeSubst :: (Eq v, Hashable v) => SubstV v -> v -> SubstV v+removeSubst :: Subst -> Symbol -> Subst removeSubst (Su su) x = Su $ M.delete x su --- | Variable names for which we can propose variations to avoid name captures-class Refreshable v where-  -- | Variations of a variable name. They must contain at least a fresh name in-  -- the contexts where @candidates@ is used.-  candidates :: v -> [v]--instance Refreshable Symbol where-  candidates x = [ renameSubstSymbol x i | i <- [0..] ]---- | Rapier style capture-avoiding substitution------ The scope set parameter must contain any symbols that are expected--- to appear free in the result expression. Typically, this is the set of--- symbols that are free in the range of the substitution, plus any symbols--- that are already free in the input expression.-rapierSubstExpr :: (Hashable v, Refreshable v) => S.HashSet v -> SubstV v -> ExprBV v v -> ExprBV v v-rapierSubstExpr s su e0 =-  let go = rapierSubstExpr-   in case e0 of-    EApp f e -> EApp (go s su f) (go s su e)-    ELam (x, t) e ->-      if x `S.member` s then-        let x' = fresh x-            su' = extendSubst su x (EVar x')-         in ELam (x', t) (go (S.insert x' s) su' e)-      else-        ELam (x, t) (go (S.insert x s) (removeSubst su x) e)-    ELet x e1 e2 ->-      if x `S.member` s then-        let x' = fresh x-            su' = extendSubst su x (EVar x')-         in ELet x' (go s su e1) (go (S.insert x' s) su' e2)-      else-        let su' = removeSubst su x-         in ELet x (go s su e1) (go (S.insert x s) su' e2)--    ECoerc a t e -> ECoerc a t (go s su e)-    ENeg e -> ENeg (go s su e)-    EBin op e1 e2 -> EBin op (go s su e1) (go s su e2)-    EIte p e1 e2 -> EIte (go s su p) (go s su e1) (go s su e2)-    ECst e so -> ECst (go s su e) so-    EVar x -> appSubst su x-    PAnd ps -> PAnd $ map (go s su) ps-    POr ps -> POr $ map (go s su) ps-    PNot p -> PNot $ go s su p-    PImp p1 p2 -> PImp (go s su p1) (go s su p2)-    PIff p1 p2 -> PIff (go s su p1) (go s su p2)-    PAtom r e1 e2 -> PAtom r (go s su e1) (go s su e2)-    PKVar k tsu su' -> PKVar k tsu (catSubstGo su' su)-    PAll bs p ->-      let mfs = map (maybeFresh . fst) bs-          fs = map (either (\x -> (x, x)) id) mfs-          su' = List.foldl' (\su1 (x, x') -> extendSubst su1 x (EVar x')) su fs-          bs' = zip (map (either id snd) mfs) (map snd bs)-          s' = foldr (S.insert . fst) s bs'-       in-          PAll bs' $ go s' su' p-    PExist bs p ->-      let mfs = map (maybeFresh . fst) bs-          fs = map (either (\x -> (x, x)) id) mfs-          su' = List.foldl' (\su1 (x, x') -> extendSubst su1 x (EVar x')) su fs-          bs' = zip (map (either id snd) mfs) (map snd bs)-          s' = foldr (S.insert . fst) s bs'-       in-          PExist bs' $ go s' su' p-    p -> p+disjoint :: Subst -> [(Symbol, Sort)] -> Bool+disjoint (Su su) bs = S.null $ suSyms `S.intersection` bsSyms   where-    fresh x = head $ dropWhile (`S.member` s) (candidates x)+    suSyms = S.fromList $ syms (M.elems su) ++ syms (M.keys su)+    bsSyms = S.fromList $ syms $ fst <$> bs -    maybeFresh x =-      if x `S.member` s then Right (x, fresh x) else Left x+instance Semigroup Expr where+  p <> q = pAnd [p, q] -    catSubstGo su1 su2@(Su s2) = toKVarSubst $ M.union s1 s2-      where-        s1 = rapierSubstExpr s su2 <$> fromKVarSubst su1+instance Monoid Expr where+  mempty  = PTrue+  mappend = (<>)+  mconcat = pAnd -extendSubst :: Hashable v => SubstV v -> v -> ExprBV v v -> SubstV v-extendSubst (Su m) x e = Su $ M.insert x e m+instance Semigroup Reft where+  (<>) = meetReft -disjointRange :: (Eq v, Hashable v) => SubstV v -> [(v, Sort)] -> Bool-disjointRange (Su su) bs = S.null $ suSyms `S.intersection` bsSyms-  where-    suSyms = S.fromList $ syms (M.elems su)-    bsSyms = S.fromList $ fst <$> bs+instance Monoid Reft where+  mempty  = trueReft+  mappend = (<>) -meetReft :: Binder v => ReftBV v v -> ReftBV v v -> ReftBV v v+meetReft :: Reft -> Reft -> Reft meetReft (Reft (v, ra)) (Reft (v', ra'))-  | v == v'          = Reft (v , pAnd [ra, ra'])-  | v == wildcard    = Reft (v', pAnd [ra', ra `subst1`  (v , EVar v')])-  | otherwise        = Reft (v , pAnd [ra, ra' `subst1` (v', EVar v )])+  | v == v'          = Reft (v , ra  `mappend` ra')+  | v == dummySymbol = Reft (v', ra' `mappend` (ra `subst1`  (v , EVar v')))+  | otherwise        = Reft (v , ra  `mappend` (ra' `subst1` (v', EVar v ))) -instance (Eq v, Hashable v, Refreshable v) => Subable (ReftBV v v) where-  type Variable (ReftBV v v) = v+instance Semigroup SortedReft where+  t1 <> t2 = RR (mappend (sr_sort t1) (sr_sort t2)) (mappend (sr_reft t1) (sr_reft t2))++instance Monoid SortedReft where+  mempty  = RR mempty mempty+  mappend = (<>)++instance Subable Reft where   syms (Reft (v, ras))      = v : syms ras   substa f (Reft (v, ras))  = Reft (f v, substa f ras)-  subst su (Reft (v, ras))  =-    let su' = substExcept su [v]-        s = S.union (substSymbolsSet su') (exprSymbolsSet ras)-     in Reft (v, rapierSubstExpr s su' ras)+  subst su (Reft (v, ras))  = Reft (v, subst (substExcept su [v]) ras)   substf f (Reft (v, ras))  = Reft (v, substf (substfExcept f [v]) ras)   subst1 (Reft (v, ras)) su = Reft (v, subst1Except [v] ras su) @@ -356,6 +221,25 @@   substf f (RR so r) = RR so $ substf f r   substa f (RR so r) = RR so $ substa f r +instance Reftable () where+  isTauto _ = True+  ppTy _  d = d+  top  _    = ()+  bot  _    = ()+  meet _ _  = ()+  toReft _  = mempty+  ofReft _  = mempty+  params _  = []++instance Reftable Reft where+  isTauto  = all isTautoPred . conjuncts . reftPred+  ppTy     = pprReft+  toReft   = id+  ofReft   = id+  params _ = []+  bot    _        = falseReft+  top (Reft(v,_)) = Reft (v, mempty)+ pprReft :: Reft -> Doc -> Doc pprReft (Reft (v, p)) d   | isTautoPred p@@ -363,10 +247,19 @@   | otherwise   = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas [p]) +instance Reftable SortedReft where+  isTauto  = isTauto . toReft+  ppTy     = ppTy . toReft+  toReft   = sr_reft+  ofReft   = errorstar "No instance of ofReft for SortedReft"+  params _ = []+  bot s    = s { sr_reft = falseReft }+  top s    = s { sr_reft = trueReft }+ -- RJ: this depends on `isTauto` hence, here.-instance (PPrint v, Fixpoint v, Ord v) => PPrint (ReftV v) where+instance PPrint Reft where   pprintTidy k r-    | isTautoReft r        = text "true"+    | isTauto r        = text "true"     | otherwise        = pprintReft k r  instance PPrint SortedReft where@@ -381,7 +274,6 @@   toFix (RR so (Reft (v, ra)))     = braces     $ toFix v <+> text ":" <+> toFix so <+> text "|" <+> toFix (conjuncts ra)-  simplify (RR so (Reft (v, ra))) = RR (simplify so) (Reft (simplify v, simplify ra))  instance Show Reft where   show = showFix@@ -424,7 +316,7 @@     -- go _                  = []  -exprSymbols :: (Eq v, Hashable v) => ExprBV v v -> [v]+exprSymbols :: Expr -> [Symbol] exprSymbols = S.toList . exprSymbolsSet  instance Expression (Symbol, SortedReft) where
src/Language/Fixpoint/Types/Templates.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE FlexibleInstances #-} module Language.Fixpoint.Types.Templates ( -  anything, Templates, makeTemplates,+  anything, Templates, makeTemplates,     isEmptyTemplates, isAnyTemplates, @@ -14,94 +13,94 @@ import Language.Fixpoint.Types.PrettyPrint import Text.PrettyPrint.HughesPJ.Compat -data Templates-  = TAll-  | TExprs [Template]+data Templates +  = TAll +  | TExprs [Template]    deriving Show   type Template = ([Symbol], Expr)  -class HasTemplates a where-  filterUnMatched :: Templates -> a -> a+class HasTemplates a where +  filterUnMatched :: Templates -> a -> a    instance HasTemplates Expr where-  filterUnMatched temps e = pAnd $ filter (not . matchesTemplates temps) $ conjuncts e+  filterUnMatched temps e = pAnd $ filter (not . matchesTemplates temps) $ conjuncts e   instance HasTemplates Reft where   filterUnMatched temps (Reft (x,e)) = Reft (x, filterUnMatched temps e) -matchesTemplates :: Templates -> Expr -> Bool-matchesTemplates TAll _ = True+matchesTemplates :: Templates -> Expr -> Bool +matchesTemplates TAll _ = True  matchesTemplates (TExprs ts) e = any (`matchesTemplate` e) ts -matchesTemplate :: Template -> Expr -> Bool+matchesTemplate :: Template -> Expr -> Bool  matchesTemplate (xs, t@(EVar x)) e-  = x `elem` xs || e == t-matchesTemplate (xs, EApp t1 t2) (EApp e1 e2)-  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2-matchesTemplate (xs, ENeg t) (ENeg e)+  = x `elem` xs || e == t  +matchesTemplate (xs, EApp t1 t2) (EApp e1 e2) +  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, ENeg t) (ENeg e)    = matchesTemplate (xs, t) e-matchesTemplate (xs, EBin b t1 t2) (EBin b' e1 e2)-  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2-matchesTemplate (xs, ELet x t1 t2) (ELet x' e1 e2)-  = x == x' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2-matchesTemplate (xs, EIte t1 t2 t3) (EIte e1 e2 e3)-  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 && matchesTemplate (xs, t3) e3-matchesTemplate (xs, ECst t s) (ECst e s')+matchesTemplate (xs, EBin b t1 t2) (EBin b' e1 e2) +  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, EIte t1 t2 t3) (EIte e1 e2 e3) +  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 && matchesTemplate (xs, t3) e3 +matchesTemplate (xs, ECst t s) (ECst e s')    = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, ELam b t) (ELam b' e)+matchesTemplate (xs, ELam b t) (ELam b' e)    = b == b' && matchesTemplate (xs, t) e-matchesTemplate (xs, ETApp t s) (ETApp e s')+matchesTemplate (xs, ETApp t s) (ETApp e s')    = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, ETAbs t s) (ETAbs e s')+matchesTemplate (xs, ETAbs t s) (ETAbs e s')    = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, PNot t) (PNot e)+matchesTemplate (xs, PNot t) (PNot e)    = matchesTemplate (xs, t) e-matchesTemplate (xs, PAnd ts) (PAnd es)-  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es-matchesTemplate (xs, POr ts) (POr es)-  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es-matchesTemplate (xs, PImp t1 t2) (PImp e1 e2)-  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2-matchesTemplate (xs, PIff t1 t2) (PIff e1 e2)-  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2-matchesTemplate (xs, PAtom b t1 t2) (PAtom b' e1 e2)-  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2-matchesTemplate (xs, PAll s t) (PAll s' e)+matchesTemplate (xs, PAnd ts) (PAnd es) +  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es +matchesTemplate (xs, POr ts) (POr es) +  = and $ zipWith (\t e -> matchesTemplate (xs, t) e) ts es +matchesTemplate (xs, PImp t1 t2) (PImp e1 e2) +  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, PIff t1 t2) (PIff e1 e2) +  = matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, PAtom b t1 t2) (PAtom b' e1 e2) +  = b == b' && matchesTemplate (xs, t1) e1 && matchesTemplate (xs, t2) e2 +matchesTemplate (xs, PAll s t) (PAll s' e)    = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, PExist s t) (PExist s' e)+matchesTemplate (xs, PExist s t) (PExist s' e)    = s == s' && matchesTemplate (xs, t) e-matchesTemplate (xs, ECoerc s1 s2 t) (ECoerc s1' s2' e)+matchesTemplate (xs, PGrad s1 s2 s3 t) (PGrad s1' s2' s3' e) +  = s1 == s1' && s2 == s2' && s3 == s3' && matchesTemplate (xs, t) e+matchesTemplate (xs, ECoerc s1 s2 t) (ECoerc s1' s2' e)    = s1 == s1' && s2 == s2' && matchesTemplate (xs, t) e-matchesTemplate (_, t) e-  = t == e+matchesTemplate (_, t) e +  = t == e     makeTemplates :: [([Symbol], Expr)] -> Templates-makeTemplates = TExprs+makeTemplates = TExprs   -isEmptyTemplates, isAnyTemplates :: Templates -> Bool-isEmptyTemplates (TExprs []) = True-isEmptyTemplates _           = False+isEmptyTemplates, isAnyTemplates :: Templates -> Bool +isEmptyTemplates (TExprs []) = True +isEmptyTemplates _           = False  -isAnyTemplates TAll = True-isAnyTemplates _    = False+isAnyTemplates TAll = True +isAnyTemplates _    = False   anything :: Templates anything = TAll -instance Semigroup Templates where+instance Semigroup Templates where    TAll <> _ = TAll   _ <> TAll = TAll   TExprs i1 <> TExprs i2 = TExprs (i1 ++ i2) -instance Monoid Templates where-  mempty = TExprs []+instance Monoid Templates where +  mempty = TExprs []   instance PPrint Templates where-  pprintTidy _ = text . show+  pprintTidy _ = text . show
src/Language/Fixpoint/Types/Theories.hs view
@@ -4,9 +4,6 @@ {-# LANGUAGE PatternGuards              #-} {-# LANGUAGE DeriveDataTypeable         #-} -{-# OPTIONS_GHC -Wno-orphans            #-}-{-# OPTIONS_GHC -Wno-name-shadowing     #-}- -- | This module contains the types defining an SMTLIB2 interface.  module Language.Fixpoint.Types.Theories (@@ -20,168 +17,137 @@      -- * Theory Sorts     , SmtSort (..)-    , FuncSort     , sortSmtSort     , isIntSmtSort -    , mergeTopAppls-    , pushAppls-    , popAppls-    , peekAppls-     -- * Symbol Environments     , SymEnv (..)-    , SymM     , symEnv     , symEnvSort     , symEnvTheory     , insertSymEnv-    , deleteSymEnv     , insertsSymEnv-    , deletesSymEnv     , symbolAtName-    , symbolAtSortIndex+    , symbolAtSmtName -    -- * Coercing sorts in environments-    , coerceSort-    , coerceEnv-    , coerceSortEnv-    , TheorySymbols(..)+     ) where   import           Data.Generics             (Data)+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup            (Semigroup (..))+#endif+ import           Data.Typeable             (Typeable) import           Data.Hashable import           GHC.Generics              (Generic)-import           Control.Applicative-import           Control.Monad.State import           Control.DeepSeq-import           Language.Fixpoint.Types.Config import           Language.Fixpoint.Types.PrettyPrint import           Language.Fixpoint.Types.Names import           Language.Fixpoint.Types.Sorts+import           Language.Fixpoint.Types.Errors import           Language.Fixpoint.Types.Environments  import           Text.PrettyPrint.HughesPJ.Compat-import qualified Data.List                as L+import qualified Data.List                as L  import           Data.Text (Text) import qualified Data.Text                as Text+import qualified Data.Text.Lazy           as LT import qualified Data.Store              as S import qualified Data.HashMap.Strict      as M-import qualified Language.Fixpoint.Misc   as Misc+import qualified Language.Fixpoint.Misc   as Misc +import Data.Functor.Contravariant (Contravariant(contramap))  -------------------------------------------------------------------------------- -- | 'Raw' is the low-level representation for SMT values ---------------------------------------------------------------------------------type Raw = 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' ------------------------------------------------------------------------------------ | Apply tags already used to declare @apply@ symbols in the SMT solver.------ The tags are organized in a stack because every time we pop the SMT solver--- state, it forgets the tags declared since the last push.------ Each entry in the stack describes the integer tag corresponding to a--- particular function sort. Every time we issue a `push` a new level--- is added to the stack, and correspondingly, a `pop` removes a level.------ See 'seApplsCur' in 'SymEnv' for details about actually declaring the--- tags to the SMT solver.-type Appls = [M.HashMap FuncSort Int]--lookupAppls :: FuncSort -> Appls -> Maybe Int-lookupAppls fs = foldr (\hm acc -> acc <|> M.lookup fs hm) Nothing--mergeTopAppls :: M.HashMap FuncSort Int -> Appls -> Appls-mergeTopAppls m (top : rest) = (top <> m) : rest-mergeTopAppls m [] = [m]--pushAppls :: Appls -> Appls-pushAppls aps = M.empty : aps--popAppls :: Appls -> Appls-popAppls [] = []-popAppls (_:xs) = xs--peekAppls :: Appls -> Maybe (M.HashMap FuncSort Int)-peekAppls [] = Nothing-peekAppls (x:_) = Just x- data SymEnv = SymEnv-  { seSort     :: !(SEnv Sort)              -- ^ Sorts of *all* defined symbols-  , seTheory   :: !(SEnv TheorySymbol)      -- ^ Information about theory-specific Symbols-  , seData     :: !(SEnv DataDecl)          -- ^ User-defined data-declarations-  , seLits     :: !(SEnv Sort)              -- ^ Distinct Constant symbols--    -- | Apply tags already declared in the SMT solver.-    ---    -- This is inspected when serializing applications of functions to determine-    -- if a new tag needs to be created for a given function sort-    -- (@funcSortIndex@).-  , seAppls    :: !Appls--    -- | Apply tags that have been created while serializing expressions for the-    -- SMT solver, but which have not been used to declare apply symbols yet in-    -- the SMT solver.-    ---    -- The apply symbols using the tags are declared whenever we need to send-    -- the serialized expressions to the SMT solver (using @funcSortVars@). At-    -- this point, the contents of this map are merged into the top of the-    -- 'seAppls' stack, and @seApplsCur@ is cleared.-  , seApplsCur :: !(M.HashMap FuncSort Int)-  , seIx       :: !Int                      -- ^ Largest unused index for sorts-  , seString   :: !Bool                     -- ^ Use string literals+  { seSort    :: !(SEnv Sort)              -- ^ Sorts of *all* defined symbols+  , seTheory  :: !(SEnv TheorySymbol)      -- ^ Information about theory-specific Symbols+  , seData    :: !(SEnv DataDecl)          -- ^ User-defined data-declarations+  , seLits    :: !(SEnv Sort)              -- ^ Distinct Constant symbols+  , seAppls   :: !(M.HashMap FuncSort Int) -- ^ Types at which `apply` was used;+                                           --   see [NOTE:apply-monomorphization]   }   deriving (Eq, Show, Data, Typeable, Generic)  {- type FuncSort = {v:Sort | isFFunc v} @-} type FuncSort = (SmtSort, SmtSort) --- | Generating SMT expressions is a stateful process because new symbols ('apply', 'coerce',---   'smt_lambda' and 'lam_arg') need to be emitted with unique ids for each newly encountered---   function sort. The 'SymM' monad carries the 'SymEnv' state required to track the ids.---   The state updates are performed in `L.F.Smt.Serialize` (functions `smt2App`, `smt2Coerc`,---   `smt2Lam` and `smtLamArg`, correspondingly).-type SymM a = State SymEnv a- instance NFData   SymEnv instance S.Store SymEnv  instance Semigroup SymEnv where-  e1 <> e2 = SymEnv { seSort     = seSort     e1 <> seSort     e2-                    , seTheory   = seTheory   e1 <> seTheory   e2-                    , seData     = seData     e1 <> seData     e2-                    , seLits     = seLits     e1 <> seLits     e2-                    , seAppls    = zipWith (<>) (seAppls e1) (seAppls e2)-                    , seApplsCur = seApplsCur e1 <> seApplsCur e2-                    , seIx       = seIx       e1 `max` seIx    e2-                    , seString   = seString e1 && seString e2+  e1 <> e2 = SymEnv { seSort   = seSort   e1 <> seSort   e2+                    , seTheory = seTheory e1 <> seTheory e2+                    , seData   = seData   e1 <> seData   e2+                    , seLits   = seLits   e1 <> seLits   e2+                    , seAppls  = seAppls  e1 <> seAppls  e2                     }  instance Monoid SymEnv where-  mempty        = SymEnv emptySEnv emptySEnv emptySEnv emptySEnv [] mempty 0 True+  mempty        = SymEnv emptySEnv emptySEnv emptySEnv emptySEnv mempty   mappend       = (<>) -symEnv :: Config -> SEnv Sort -> SEnv TheorySymbol -> [DataDecl] -> SEnv Sort -> [Sort] -> SymEnv-symEnv cfg xEnv fEnv ds ls _ = SymEnv xEnv' fEnv dEnv ls [] mempty 0 seStr+symEnv :: SEnv Sort -> SEnv TheorySymbol -> [DataDecl] -> SEnv Sort -> [Sort] -> SymEnv+symEnv xEnv fEnv ds ls ts = SymEnv xEnv' fEnv dEnv ls sortMap   where-    xEnv'   = unionSEnv xEnv wiredInEnv-    dEnv    = fromListSEnv [(symbol d, d) | d <- ds]-    seStr   = not (noStringTheory cfg)+    xEnv'                 = unionSEnv xEnv wiredInEnv+    dEnv                  = fromListSEnv [(symbol d, d) | d <- ds]+    sortMap               = M.fromList (zip smts [0..])+    smts                  = funcSorts dEnv ts   -- | These are "BUILT-in" polymorphic functions which are---   UNINTERPRETED but POLYMORPHIC, hence need to go through+--   UNININTERPRETED but POLYMORPHIC, hence need to go through --   the apply-defunc stuff. wiredInEnv :: M.HashMap Symbol Sort-wiredInEnv = M.fromList+wiredInEnv = M.fromList    [ (toIntName, mkFFunc 1 [FVar 0, FInt])   , (tyCastName, FAbs 0 $ FAbs 1 $ FFunc (FVar 0) (FVar 1))   ] ++-- | 'smtSorts' attempts to compute a list of all the input-output sorts+--   at which applications occur. This is a gross hack; as during unfolding+--   we may create _new_ terms with wierd new sorts. Ideally, we MUST allow+--   for EXTENDING the apply-sorts with those newly created terms.+--   the solution is perhaps to *preface* each VC query of the form+--+--      push+--      assert p+--      check-sat+--      pop+--+--   with the declarations needed to make 'p' well-sorted under SMT, i.e.+--   change the above to+--+--      declare apply-sorts+--      push+--      assert p+--      check-sat+--      pop+--+--   such a strategy would NUKE the entire apply-sort machinery from the CODE base.+--   [TODO]: dynamic-apply-declaration++funcSorts :: SEnv DataDecl -> [Sort] -> [FuncSort]+funcSorts dEnv ts = [ (t1, t2) | t1 <- smts, t2 <- smts]+  where+    smts         = Misc.sortNub $ concat [ [tx t1, tx t2] | FFunc t1 t2 <- ts]+    tx           = applySmtSort dEnv++ symEnvTheory :: Symbol -> SymEnv -> Maybe TheorySymbol symEnvTheory x env = lookupSEnv x (seTheory env) @@ -191,45 +157,28 @@ insertSymEnv :: Symbol -> Sort -> SymEnv -> SymEnv insertSymEnv x t env = env { seSort = insertSEnv x t (seSort env) } -deleteSymEnv :: Symbol -> SymEnv -> SymEnv-deleteSymEnv x env = env { seSort = deleteSEnv x (seSort env) }- insertsSymEnv :: SymEnv -> [(Symbol, Sort)] -> SymEnv-insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env)--deletesSymEnv :: SymEnv -> [Symbol] -> SymEnv-deletesSymEnv = L.foldl' (\env x -> deleteSymEnv x env)--symbolAtSortIndex :: Symbol -> Int -> Text-symbolAtSortIndex mkSym si = appendSymbolText mkSym . Text.pack . show $ si+insertsSymEnv = L.foldl' (\env (x, s) -> insertSymEnv x s env)  -symbolAtName :: Symbol -> Sort -> SymM Text-symbolAtName mkSym s =-  do env <- get-     fsi <- funcSortIndex (ffuncSort env s)-     pure $ symbolAtSortIndex mkSym fsi+symbolAtName :: (PPrint a) => Symbol -> SymEnv -> a -> Sort -> Text+symbolAtName mkSym env e = symbolAtSmtName mkSym env e . ffuncSort env {-# SCC symbolAtName #-} --- See 'seAppls' and 'seApplsCur' in 'SymEnv' for explanation.-funcSortIndex :: FuncSort -> SymM Int-funcSortIndex fs =-  do env <- get-     let aps = seAppls env-     let apsc = seApplsCur env-     case lookupAppls fs aps of-      Just i  -> pure i-      Nothing ->-        case M.lookup fs apsc of-          Just i  -> pure i-          Nothing ->-           do let i = seIx env-              modify (\env -> env { seApplsCur = M.insert fs i apsc , seIx = 1 + i })-              pure i+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)+  where+    err               = panic ("Unknown func-sort: " ++ showpp z ++ " for " ++ showpp e)+ ffuncSort :: SymEnv -> Sort -> FuncSort ffuncSort env t      = {- tracepp ("ffuncSort " ++ showpp (t1,t2)) -} (tx t1, tx t2)   where-    tx               = applySmtSort (seData env)+    tx               = applySmtSort (seData env)      (t1, t2)         = args t     args (FFunc a b) = (a, b)     args _           = (FInt, FInt)@@ -251,10 +200,6 @@   }   deriving (Eq, Ord, Show, Data, Typeable, Generic) --class TheorySymbols a where-  theorySymbols :: a ->  SEnv TheorySymbol- instance NFData Sem instance NFData TheorySymbol instance S.Store TheorySymbol@@ -274,11 +219,10 @@  data Sem   = Uninterp      -- ^ for UDF: `len`, `height`, `append`-  | Ctor          -- ^ for ADT constructor and tests: `cons`, `nil`+  | Ctor         -- ^ for ADT constructor and tests: `cons`, `nil`   | Test          -- ^ for ADT tests : `is$cons`   | Field         -- ^ for ADT field: `hd`, `tl`   | Theory        -- ^ for theory ops: mem, cup, select-  | Defined       -- ^ for user-defined `define-fun`   deriving (Eq, Ord, Show, Data, Typeable, Generic)  instance S.Store Sem@@ -292,12 +236,8 @@   | SBool   | SReal   | SString-  --- CVC(5) only-  | SSet !SmtSort-  | SBag !SmtSort-  | SFFld !Integer-  ----  | SArray !SmtSort !SmtSort+  | SSet+  | SMap   | SBitVec !Int   | SVar    !Int   | SData   !FTycon ![SmtSort]@@ -314,40 +254,30 @@ --   using `Int` (though really, there SHOULD BE NO floating tyVars... --   'smtSort True  msg t' serializes a sort 't' using type variables, --   'smtSort False msg t' serializes a sort 't' using 'Int' instead of tyvars.-sortSmtSort :: Bool -> SEnv DataDecl -> Sort -> SmtSort-sortSmtSort poly env t = sortSmtSort' poly env m t-  where-    m = sortAbs t -sortSmtSort' :: Bool -> SEnv DataDecl -> Int -> Sort -> SmtSort-sortSmtSort' poly env m t = go . unAbs $ t+sortSmtSort :: Bool -> SEnv DataDecl -> Sort -> SmtSort+sortSmtSort poly env t  = {- tracepp ("sortSmtSort: " ++ showpp t) else id) $ -}  go . unAbs $ t   where+    m = sortAbs t      go (FFunc _ _)    = SInt     go FInt           = SInt     go FReal          = SReal     go t       | t == boolSort = SBool-      | isString t    = SString+      | isString t    = SString      go (FVar i)       | poly, i < m   = SVar i       | otherwise     = SInt-    go t-      | (ct:ts) <- unFApp t = fappSmtSort poly m env ct ts-      | otherwise = error "Unexpected empty 'unFApp t'"+    go t              = fappSmtSort poly m env ct ts where (ct:ts) = unFApp t  fappSmtSort :: Bool -> Int -> SEnv DataDecl -> Sort -> [Sort] -> SmtSort fappSmtSort poly m env = go   where-    -- See https://github.com/ucsd-progsys/liquid-fixpoint/pull/839 for why-    -- @FAbs m@ is re-added.-    go (FTC c) [a]-      | setConName == symbol c   = SSet (sortSmtSort' poly env m a)-    go (FTC c) [a]-      | bagConName == symbol c   = SBag (sortSmtSort' poly env m a)-    go (FTC c) [FNatNum n]-      | ffldConName == symbol c  = SFFld n-    go (FTC c) [a, b]-      | arrayConName == symbol c = SArray (sortSmtSort' poly env m a) (sortSmtSort' poly env m b)+-- HKT    go t@(FVar _) ts            = SApp (sortSmtSort poly env <$> (t:ts))+    go (FTC c) _+      | setConName == symbol c  = SSet+    go (FTC c) _+      | mapConName == symbol c  = SMap     go (FTC bv) [FTC s]       | bitVecName == symbol bv       , Just n <- sizeBv s      = SBitVec n@@ -355,7 +285,7 @@       | isString s              = SString     go (FTC c) ts       | Just n <- tyArgs c env-      , let i = n - length ts   = SData c ((sortSmtSort' poly env m <$> ts) ++ pad i)+      , let i = n - length ts   = SData c ((sortSmtSort poly env . FAbs m <$> ts) ++ pad i)     go _ _                      = SInt      pad i | poly                = []@@ -369,10 +299,8 @@   pprintTidy _ SBool        = text "Bool"   pprintTidy _ SReal        = text "Real"   pprintTidy _ SString      = text "Str"-  pprintTidy k (SSet a)     = ppParens k (text "Set") [a]-  pprintTidy k (SBag a)     = ppParens k (text "Bag") [a]-  pprintTidy _ (SFFld n)    = text "FiniteField" <+> integer n-  pprintTidy k (SArray a b) = ppParens k (text "Array") [a, b]+  pprintTidy _ SSet         = text "Set"+  pprintTidy _ SMap         = text "Map"   pprintTidy _ (SBitVec n)  = text "BitVec" <+> int n   pprintTidy _ (SVar i)     = text "@" <-> int i --  HKT pprintTidy k (SApp ts)    = ppParens k (pprintTidy k tyAppName) ts@@ -380,25 +308,3 @@  ppParens :: (PPrint d) => Tidy -> Doc -> [d] -> Doc ppParens k d ds = parens $ Misc.intersperse (text "") (d : (pprintTidy k <$> ds))------------------------------------------------------------------------------------- | Coercing sorts inside environments for SMT theory encoding-----------------------------------------------------------------------------------coerceSortEnv :: ElabFlags -> SEnv Sort -> SEnv Sort-coerceSortEnv ef ss = coerceSort ef <$> ss--coerceSort :: ElabFlags -> Sort -> Sort-coerceSort ef = (if elabSetBag ef then coerceSetBagToArray else id) . coerceMapToArray--coerceEnv :: ElabFlags -> SymEnv -> SymEnv-coerceEnv slv env =-  SymEnv { seSort     = coerceSortEnv slv (seSort env)-         , seTheory   = seTheory env-         , seData     = seData   env-         , seLits     = seLits   env-         , seAppls    = seAppls  env-         , seApplsCur = seApplsCur env-         , seIx       = seIx     env-         , seString   = seString env-         }
src/Language/Fixpoint/Types/Triggers.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} @@ -17,7 +18,7 @@ import           Text.PrettyPrint.HughesPJ  import Language.Fixpoint.Types.Refinements-import Language.Fixpoint.Types.PrettyPrint+import Language.Fixpoint.Types.PrettyPrint  import Language.Fixpoint.Misc              (errorstar)  @@ -27,10 +28,10 @@ data Trigger = NoTrigger | LeftHandSide   deriving (Eq, Show, Generic) -instance PPrint Trigger where-  pprintTidy _ = text . show+instance PPrint Trigger where +  pprintTidy _ = text . show  -instance PPrint a => PPrint (Triggered a) where+instance PPrint a => PPrint (Triggered a) where    pprintTidy k (TR t x) = parens (pprintTidy k t <+> text ":" <+> pprintTidy k x)  noTrigger :: e -> Triggered e
src/Language/Fixpoint/Types/Utils.hs view
@@ -31,14 +31,14 @@ -------------------------------------------------------------------------------- -- | Compute the domain of a kvar ---------------------------------------------------------------------------------kvarDomain :: GInfo c a -> KVar -> [Symbol]+kvarDomain :: SInfo a -> KVar -> [Symbol] -------------------------------------------------------------------------------- kvarDomain si k = domain (bs si) (getWfC si k) -domain :: BindEnv a -> WfC a -> [Symbol]+domain :: BindEnv -> WfC a -> [Symbol] domain be wfc = fst3 (wrft wfc) : map fst (envCs be $ wenv wfc) -getWfC :: GInfo c a -> KVar -> WfC a+getWfC :: SInfo a -> KVar -> WfC a getWfC si k = ws si M.! k  --------------------------------------------------------------------------------@@ -49,20 +49,19 @@ reftFreeVars r@(Reft (v, _)) = S.delete v $ S.fromList $ syms r  ----------------------------------------------------------------------------------- | Split a SortedReft into its concrete and KVar conjuncts------ Produces @(concrete conjunts, normal kvars)@+-- | Split a SortedReft into its concrete and KVar components ---------------------------------------------------------------------------------sortedReftConcKVars :: Symbol -> SortedReft -> ([Pred], [KVSub])-sortedReftConcKVars x sr = go [] [] ves+sortedReftConcKVars :: Symbol -> SortedReft -> ([Pred], [KVSub], [KVSub])+sortedReftConcKVars x sr = go [] [] [] ves   where     ves                  = [(v, p `subst1` (v, eVar x)) | Reft (v, p) <- rs ]     rs                   = reftConjuncts (sr_reft sr)     t                    = sr_sort sr -    go ps ks ((v, PKVar k tsu su):xs) = go ps (KVS v t k su tsu:ks) xs-    go ps ks ((_, p):xs)              = go (p:ps) ks xs-    go ps ks []                       = (ps, ks)+    go ps ks gs ((v, PKVar k su    ):xs) = go ps (KVS v t k su:ks) gs xs +    go ps ks gs ((v, PGrad k su _ _):xs) = go ps ks (KVS v t k su:gs) xs +    go ps ks gs ((_, p):xs)              = go (p:ps) ks gs xs +    go ps ks gs []                       = (ps, ks, gs)   -------------------------------------------------------------------------------@@ -79,17 +78,17 @@ -------------------------------------------------------------------------------  isRegular []       = error "impossible: isRegular"-isRegular ds@(d:_) = all (\d' -> ddVars d' == nArgs) ds   -- same number of tyArgs+isRegular ds@(d:_) = all (\d' -> ddVars d' == nArgs) ds   -- same number of tyArgs                    && all isRegApp fldSortApps         -- 'regular' application (tc @0 ... @n)   where     nArgs          = ddVars d     tcs            = S.fromList ( symbol . ddTyCon <$> ds)-    fldSortApps    = [ (c,ts) | d'          <- ds-                              , ctor        <- ddCtors d'-                              , DField _ t  <- dcFields ctor+    fldSortApps    = [ (c,ts) | d           <- ds+                              , ctor        <- ddCtors d+                              , DField _ t  <- dcFields ctor                                , (c, ts)     <- sortApps t-                     ]-    isRegApp cts   = case cts of+                     ]         +    isRegApp cts   = case cts of                          (FTC c, ts) -> not (S.member (symbol c) tcs) || isRegularArgs nArgs ts                         _           -> False @@ -99,17 +98,17 @@ type SortApp = (Sort, [Sort])  sortApps :: Sort -> [SortApp]-sortApps = go-  where+sortApps = go +  where      go t@FApp {}     = (f, ts) : concatMap go ts where (f, ts) = splitApp t     go (FFunc t1 t2) = go t1 ++ go t2     go (FAbs _ t)    = go t     go _             = [] -splitApp :: Sort -> SortApp+splitApp :: Sort -> SortApp  splitApp = go []   where-    go stk (FApp t1 t2) = go (t2:stk) t1+    go stk (FApp t1 t2) = go (t2:stk) t1       go stk t            = (t, stk)  --------------------------------------------------------------------------------@@ -141,5 +140,5 @@     go (FTC c)       = [c]     go (FApp  t1 t2) = go t1 ++ go t2     go (FFunc t1 t2) = go t1 ++ go t2-    go (FAbs _ t)    = go t+    go (FAbs _ t)    = go t      go _             = []
src/Language/Fixpoint/Types/Visitor.hs view
@@ -1,25 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns  #-}--{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Language.Fixpoint.Types.Visitor (   -- * Visitor-     Folder (..)-  ,  Foldable (..)+     Visitor (..)   ,  Visitable (..)    -- * Extracting Symbolic Constants (String Literals)   ,  SymConsts (..)-  ,  getConstants    -- * Default Visitor-  , defaultFolder+  , defaultVisitor    -- * Transformers   , trans@@ -34,15 +31,12 @@   , envKVars   , envKVarsN   , rhsKVars-  , mapKVars, mapKVars', mapKVarSubsts+  , mapKVars, mapKVars', mapGVars', mapKVarSubsts   , mapExpr, mapExprOnExpr, mapMExpr    -- * Coercion Substitutions   , CoSub   , applyCoSub-  , CoSubV-  , applyCoSubV-  , applyCoercion    -- * Predicates on Constraints   , isConcC , isConc, isKvarC@@ -51,26 +45,29 @@   , foldSort   , mapSort   , foldDataDecl++  , (<$$>)++   ) where  -- import           Control.Monad.Trans.State.Strict (State, modify, runState) -- import           Control.DeepSeq+#if !MIN_VERSION_base(4,14,0)+import           Data.Semigroup      (Semigroup (..))+#endif+ import           Control.Monad.State.Strict import qualified Data.HashSet        as S import qualified Data.HashMap.Strict as M import qualified Data.List           as L import           Language.Fixpoint.Types hiding (mapSort) import qualified Language.Fixpoint.Misc as Misc-import Control.Monad.Reader-import GHC.IO (unsafePerformIO)-import Data.IORef (newIORef, readIORef, IORef, modifyIORef')-import Prelude hiding (Foldable)-import Data.Containers.ListUtils (nubOrd)    -data Folder acc ctx = Visitor {+data Visitor acc ctx = Visitor {  -- | Context @ctx@ is built in a "top-down" fashion; not "across" siblings     ctxExpr :: ctx -> Expr -> ctx @@ -82,9 +79,9 @@   }  ----------------------------------------------------------------------------------defaultFolder :: (Monoid acc) => Folder acc ctx+defaultVisitor :: (Monoid acc) => Visitor acc ctx ----------------------------------------------------------------------------------defaultFolder = Visitor+defaultVisitor = Visitor   { ctxExpr    = const   , txExpr     = \_ x -> x   , accExpr    = \_ _ -> mempty@@ -92,341 +89,211 @@  ------------------------------------------------------------------------ -fold         :: (Foldable t, Monoid a) => Folder a ctx -> ctx -> a -> t -> a-fold v c a t = snd $ execVisitM v c a foldE t---- trans is always passed () () for a and t so we don't need to use the visitor pattern--- trans        :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> t--- trans !v !c !_ !z = fst $ execVisitM v c mempty visit z--class Visitable t where-  transE :: (Expr -> Expr) -> t -> t--trans :: Visitable t => (Expr -> Expr) -> t -> t-trans f t = transE f t--instance Visitable Expr where-  transE f = vE-    where-      vE e = step e' where e' = f e-      step e@(ESym _)       = e-      step e@(ECon _)       = e-      step e@(EVar _)       = e-      step (EApp e1 e2)       = EApp (vE e1) (vE e2)-      step (ENeg e)         = ENeg (vE e)-      step (EBin o e1 e2)   = EBin o (vE e1) (vE e2)-      step (ELet x e1 e2)   = ELet x (vE e1) (vE e2)-      step (EIte p e1 e2)   = EIte (vE p) (vE e1) (vE e2)-      step (ECst e t)       = ECst (vE e) t-      step (PAnd ps)        = PAnd (map vE ps)-      step (POr ps)         = POr (map vE ps)-      step (PNot p)         = PNot (vE p)-      step (PImp p1 p2)     = PImp (vE p1) (vE p2)-      step (PIff p1 p2)     = PIff (vE p1) (vE p2)-      step (PAtom r e1 e2)  = PAtom r (vE e1) (vE e2)-      step (PAll xts p)     = PAll xts (vE p)-      step (ELam (x,t) e)   = ELam (x,t) (vE e)-      step (ECoerc a t e)   = ECoerc a t (vE e)-      step (PExist xts p)   = PExist xts (vE p)-      step (ETApp e s)      = ETApp (vE e) s-      step (ETAbs e s)      = ETAbs (vE e) s-      step p@(PKVar {})       = p--instance Visitable Reft where-  transE v (Reft (x, ra)) = Reft (x, transE v ra)--instance Visitable SortedReft where-  transE v (RR t r) = RR t (transE v r)--instance Visitable (Symbol, SortedReft, a) where-  transE f (sym, sr, a) = (sym, transE f sr, a)--instance Visitable (BindEnv a) where-  transE v be = be { beBinds = M.map (transE v) (beBinds be) }--instance (Visitable (c a)) => Visitable (GInfo c a) where-  transE f x = x {-    cm = transE f <$> cm x-    , bs = transE f (bs x)-    , ae = transE f (ae x)-    }--instance Visitable (SimpC a) where-  transE v x = x {-    _crhs = transE v (_crhs x)-  }--instance Visitable (SubC a) where-  transE v x = x {-    slhs = transE v (slhs x),-    srhs = transE v (srhs x)-  }--instance Visitable AxiomEnv where-  transE v x = x {-    aenvEqs = transE v <$> aenvEqs x,-    aenvSimpl = transE v <$> aenvSimpl x-  }+fold         :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> a+fold v c a t = snd $ execVisitM v c a visit t -instance Visitable Equation where-  transE v eq = eq {-    eqBody = transE v (eqBody eq)-  }+trans        :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> t+trans v c _ z = fst $ execVisitM v c mempty visit z -instance Visitable Rewrite where-  transE v rw = rw {-    smBody = transE v (smBody rw)-  }+execVisitM :: Visitor a ctx -> ctx -> a -> (Visitor a ctx -> ctx -> t -> State a t) -> t -> (t, a)+execVisitM v c a f x = runState (f v c x) a -execVisitM :: Folder a ctx -> ctx -> a -> (Folder a ctx -> ctx -> t -> FoldM a t) -> t -> (t, a)-execVisitM !v !c !a !f !x = unsafePerformIO $ do-  rn <- newIORef a-  result <- runReaderT (f v c x) rn-  finalAcc <- readIORef rn-  return (result, finalAcc)+type VisitM acc = State acc -type FoldM acc = ReaderT (IORef acc) IO+accum :: (Monoid a) => a -> VisitM a ()+accum !z = modify (mappend z)+  -- do+  -- !cur <- get+  -- put ((mappend $!! z) $!! cur) -accum :: (Monoid a) => a -> FoldM a ()-accum !z = do-  ref <- ask-  liftIO $ modifyIORef' ref (mappend z)+(<$$>) :: (Monad m) => (a -> m b) -> [a] -> m [b]+f <$$> xs = f Misc.<$$> xs -class Foldable t where-  foldE :: (Monoid a) => Folder a c -> c -> t -> FoldM a t+-- (<$$>) ::  (Applicative f) => (a -> f b) -> [a] -> f [b]+-- f <$$> x = traverse f x+-- _ <$$> []     = return []+-- f <$$> (x:xs) = do+  -- !y  <- f x+  -- !ys <- f <$$> xs+  -- return (y:ys)+------------------------------------------------------------------------------+class Visitable t where+  visit :: (Monoid a) => Visitor a c -> c -> t -> VisitM a t -instance Foldable Expr where-  foldE = foldExpr+instance Visitable Expr where+  visit = visitExpr -instance Foldable Reft where-  foldE v c (Reft (x, ra)) = Reft . (x, ) <$> foldE v c ra+instance Visitable Reft where+  visit v c (Reft (x, ra)) = Reft . (x, ) <$> visit v c ra -instance Foldable SortedReft where-  foldE v c (RR t r) = RR t <$> foldE v c r+instance Visitable SortedReft where+  visit v c (RR t r) = RR t <$> visit v c r -instance Foldable (Symbol, SortedReft, a) where-  foldE v c (sym, sr, a) = (sym, ,a) <$> foldE v c sr+instance Visitable (Symbol, SortedReft) where+  visit v c (sym, sr) = (sym, ) <$> visit v c sr -instance Foldable (BindEnv a) where-  foldE v c = mapM (foldE v c)+instance Visitable BindEnv where+  visit v c = mapM (visit v c)  --------------------------------------------------------------------------------- -- WARNING: these instances were written for mapKVars over GInfos only; -- check that they behave as expected before using with other clients.-instance Foldable (SimpC a) where-  foldE v c x = do-    rhs' <- foldE v c (_crhs x)+instance Visitable (SimpC a) where+  visit v c x = do+    rhs' <- visit v c (_crhs x)     return x { _crhs = rhs' } -instance Foldable (SubC a) where-  foldE v c x = do-    lhs' <- foldE v c (slhs x)-    rhs' <- foldE v c (srhs x)+instance Visitable (SubC a) where+  visit v c x = do+    lhs' <- visit v c (slhs x)+    rhs' <- visit v c (srhs x)     return x { slhs = lhs', srhs = rhs' } -instance (Foldable (c a)) => Foldable (GInfo c a) where-  foldE v c x = do-    cm' <- mapM (foldE v c) (cm x)-    bs' <- foldE v c (bs x)-    ae' <- foldE v c (ae x)+instance (Visitable (c a)) => Visitable (GInfo c a) where+  visit v c x = do+    cm' <- mapM (visit v c) (cm x)+    bs' <- visit v c (bs x)+    ae' <- visit v c (ae x)      return x { cm = cm', bs = bs', ae = ae' } -instance Foldable AxiomEnv where-  foldE v c x = do-    eqs'    <- mapM (foldE v c) (aenvEqs   x)-    simpls' <- mapM (foldE v c) (aenvSimpl x)-    return x { aenvEqs = eqs' , aenvSimpl = simpls'}+instance Visitable AxiomEnv where +  visit v c x = do +    eqs'    <- mapM (visit v c) (aenvEqs   x) +    simpls' <- mapM (visit v c) (aenvSimpl x) +    return x { aenvEqs = eqs' , aenvSimpl = simpls'}  -instance Foldable Equation where-  foldE v c eq = do-    body' <- foldE v c (eqBody eq)-    return eq { eqBody = body' }+instance Visitable Equation where +  visit v c eq = do +    body' <- visit v c (eqBody eq) +    return eq { eqBody = body' }  -instance Foldable Rewrite where-  foldE v c rw = do-    body' <- foldE v c (smBody rw)-    return rw { smBody = body' }+instance Visitable Rewrite where +  visit v c rw = do +    body' <- visit v c (smBody rw) +    return rw { smBody = body' }   ----------------------------------------------------------------------------------foldExpr :: (Monoid a) => Folder a ctx -> ctx -> Expr -> FoldM a Expr-foldExpr !v    = vE+visitExpr :: (Monoid a) => Visitor a ctx -> ctx -> Expr -> VisitM a Expr+visitExpr !v    = vE   where-    vE !c !e    = do {- SCC "visitExpr.vE.accum" -} accum acc-                     {- SCC "visitExpr.vE.step" -}  step c' e'+    vE !c !e    = do {- SCC "visitExpr.vE.accum" #-} accum acc+                     {- SCC "visitExpr.vE.step" #-}  step c' e'       where !c'  = ctxExpr v c  e             !e'  = txExpr  v c' e             !acc = accExpr v c' e-    step _ e@(ESym _)       = return e-    step _ e@(ECon _)       = return e-    step _ e@(EVar _)       = return e-    step !c (EApp f e)      = EApp        <$> vE c f  <*> vE c e-    step !c (ENeg e)        = ENeg        <$> vE c e-    step !c (EBin o e1 e2)  = EBin o      <$> vE c e1 <*> vE c e2-    step !c (ELet x e1 e2)  = ELet x      <$> vE c e1 <*> vE c e2-    step !c (EIte p e1 e2)  = EIte        <$> vE c p  <*> vE c e1 <*> vE c e2-    step !c (ECst e t)      = (`ECst` t)  <$> vE c e-    step !c (PAnd  ps)      = PAnd        <$> (vE c `traverse` ps)-    step !c (POr  ps)       = POr         <$> (vE c `traverse` ps)-    step !c (PNot p)        = PNot        <$> vE c p-    step !c (PImp p1 p2)    = PImp        <$> vE c p1 <*> vE c p2-    step !c (PIff p1 p2)    = PIff        <$> vE c p1 <*> vE c p2-    step !c (PAtom r e1 e2) = PAtom r     <$> vE c e1 <*> vE c e2-    step !c (PAll xts p)    = PAll   xts  <$> vE c p-    step !c (ELam (x,t) e)  = ELam (x,t)  <$> vE c e-    step !c (ECoerc a t e)  = ECoerc a t  <$> vE c e-    step !c (PExist xts p)  = PExist xts  <$> vE c p-    step !c (ETApp e s)     = (`ETApp` s) <$> vE c e-    step !c (ETAbs e s)     = (`ETAbs` s) <$> vE c e-    step _  p@(PKVar {})    = return p+    step _ !e@(ESym _)       = return e+    step _ !e@(ECon _)       = return e+    step _ !e@(EVar _)       = return e+    step !c !(EApp f e)      = EApp        <$> vE c f  <*> vE c e+    step !c !(ENeg e)        = ENeg        <$> vE c e+    step !c !(EBin o e1 e2)  = EBin o      <$> vE c e1 <*> vE c e2+    step !c !(EIte p e1 e2)  = EIte        <$> vE c p  <*> vE c e1 <*> vE c e2+    step !c !(ECst e t)      = (`ECst` t)  <$> vE c e+    step !c !(PAnd  ps)      = PAnd        <$> (vE c <$$> ps)+    step !c !(POr  ps)       = POr         <$> (vE c <$$> ps)+    step !c !(PNot p)        = PNot        <$> vE c p+    step !c !(PImp p1 p2)    = PImp        <$> vE c p1 <*> vE c p2+    step !c !(PIff p1 p2)    = PIff        <$> vE c p1 <*> vE c p2+    step !c !(PAtom r e1 e2) = PAtom r     <$> vE c e1 <*> vE c e2+    step !c !(PAll xts p)    = PAll   xts  <$> vE c p+    step !c !(ELam (x,t) e)  = ELam (x,t)  <$> vE c e+    step !c !(ECoerc a t e)  = ECoerc a t  <$> vE c e+    step !c !(PExist xts p)  = PExist xts  <$> vE c p+    step !c !(ETApp e s)     = (`ETApp` s) <$> vE c e+    step !c !(ETAbs e s)     = (`ETAbs` s) <$> vE c e+    step _  !p@(PKVar _ _)   = return p+    step !c !(PGrad k su i e) = PGrad k su i <$> vE c e  mapKVars :: Visitable t => (KVar -> Maybe Expr) -> t -> t mapKVars f = mapKVars' f'   where     f' (kv', _) = f kv' -mapKVars' :: Visitable t => ((KVar, KVarSubst Symbol Symbol) -> Maybe Expr) -> t -> t-mapKVars' f = trans txK+mapKVars' :: Visitable t => ((KVar, Subst) -> Maybe Expr) -> t -> t+mapKVars' f            = trans kvVis () ()   where-    txK (PKVar k tsu su)-      | Just p' <- f (k, su) = ksubst su p'-      | otherwise = PKVar k tsu su-    txK p = p+    kvVis              = defaultVisitor { txExpr = txK }+    txK _ (PKVar k su)+      | Just p' <- f (k, su) = subst su p'+    txK _ (PGrad k su _ _)+      | Just p' <- f (k, su) = subst su p'+    txK _ p            = p  ++mapGVars' :: Visitable t => ((KVar, Subst) -> Maybe Expr) -> t -> t+mapGVars' f            = trans kvVis () ()+  where+    kvVis              = defaultVisitor { txExpr = txK }+    txK _ (PGrad k su _ _)+      | Just p' <- f (k, su) = subst su p'+    txK _ p            = p+ mapExpr :: Visitable t => (Expr -> Expr) -> t -> t-mapExpr f = trans f+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 ->-        let !f' = go f-            !e' = go e-        in EApp f' e'-      ENeg e ->-        let !e' = go e-        in ENeg e'-      EBin o e1 e2 ->-        let !e1' = go e1-            !e2' = go e2-        in EBin o e1' e2'-      ELet x e1 e2 ->-        let !e1' = go e1-            !e2' = go e2-        in ELet x e1' e2'-      EIte p e1 e2 ->-        let !p' = go p-            !e1' = go e1-            !e2' = go e2-        in EIte p' e1' e2'-      ECst e t ->-        let !e' = go e-        in ECst e' t-      PAnd ps ->-        let !ps' = map go ps-        in PAnd ps'-      POr ps ->-        let !ps' = map go ps-        in POr ps'-      PNot p ->-        let !p' = go p-        in PNot p'-      PImp p1 p2 ->-        let !p1' = go p1-            !p2' = go p2-        in PImp p1' p2'-      PIff p1 p2 ->-        let !p1' = go p1-            !p2' = go p2-        in PIff p1' p2'-      PAtom r e1 e2 ->-        let !e1' = go e1-            !e2' = go e2-        in PAtom r e1' e2'-      PAll xts p ->-        let !p' = go p-        in PAll xts p'-      ELam (x,t) e ->-        let !e' = go e-        in ELam (x,t) e'-      ECoerc a t e ->-        let !e' = go e-        in ECoerc a t e'-      PExist xts p ->-        let !p' = go p-        in PExist xts p'-      ETApp e s ->-        let !e' = go e-        in ETApp e' s-      ETAbs e s ->-        let !e' = go e-        in ETAbs e' s-      PKVar k tsu su -> PKVar k tsu (mapKVarSubst go su)+    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 --- 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     go e@(ESym _)      = f e     go e@(ECon _)      = f e     go e@(EVar _)      = f e-    go e@(PKVar {})      = f e-    go (ENeg e)        = f . ENeg =<< go e-    go (PNot p)        = f . PNot =<< go p-    go (ECst e t)      = f . (`ECst` t) =<< go e-    go (PAll xts p)    = f . PAll   xts =<< go p-    go (ELam (x,t) e)  = f . ELam (x,t) =<< go e-    go (ECoerc a t e)  = f . ECoerc a t =<< go e-    go (PExist xts p)  = f . PExist xts =<< go p-    go (ETApp e s)     = f . (`ETApp` s) =<< go e-    go (ETAbs e s)     = f . (`ETAbs` s) =<< go e+    go e@(PKVar _ _)   = f e+    go (PGrad k s i e) = f =<< (PGrad k s i <$>  go e                     )+    go (ENeg e)        = f =<< (ENeg        <$>  go e                     )+    go (PNot p)        = f =<< (PNot        <$>  go p                     )+    go (ECst e t)      = f =<< ((`ECst` t)  <$>  go e                     )+    go (PAll xts p)    = f =<< (PAll   xts  <$>  go p                     )+    go (ELam (x,t) e)  = f =<< (ELam (x,t)  <$>  go e                     )+    go (ECoerc a t e)  = f =<< (ECoerc a t  <$>  go e                     )+    go (PExist xts p)  = f =<< (PExist xts  <$>  go p                     )+    go (ETApp e s)     = f =<< ((`ETApp` s) <$>  go e                     )+    go (ETAbs e s)     = f =<< ((`ETAbs` s) <$>  go e                     )     go (EApp g e)      = f =<< (EApp        <$>  go g  <*> go e           )     go (EBin o e1 e2)  = f =<< (EBin o      <$>  go e1 <*> go e2          )     go (PImp p1 p2)    = f =<< (PImp        <$>  go p1 <*> go p2          )     go (PIff p1 p2)    = f =<< (PIff        <$>  go p1 <*> go p2          )     go (PAtom r e1 e2) = f =<< (PAtom r     <$>  go e1 <*> go e2          )-    go (ELet x e1 e2)  = f =<< (ELet x      <$>  go e1 <*> go e2          )     go (EIte p e1 e2)  = f =<< (EIte        <$>  go p  <*> go e1 <*> go e2)-    go (PAnd ps)       = f . PAnd =<< (go `traverse` ps)-    go (POr ps)        = f . POr =<< (go `traverse` ps)+    go (PAnd  ps)      = f =<< (PAnd        <$> (go <$$> ps)              )+    go (POr  ps)       = f =<< (POr         <$> (go <$$> ps)              ) -mapKVarSubsts :: Visitable t => (KVar -> KVarSubst Symbol Symbol -> KVarSubst Symbol Symbol) -> t -> t-mapKVarSubsts f          = trans txK+mapKVarSubsts :: Visitable t => (KVar -> Subst -> Subst) -> t -> t+mapKVarSubsts f          = trans kvVis () ()   where-    txK (PKVar k tsu su)   = PKVar k tsu (f k su)-    txK p              = p+    kvVis                = defaultVisitor { txExpr = txK }+    txK _ (PKVar k su)   = PKVar k (f k su)+    txK _ (PGrad k su i e) = PGrad k (f k su) i e+    txK _ p              = p  newtype MInt = MInt Integer -- deriving (Eq, NFData) @@ -435,40 +302,40 @@  instance Monoid MInt where   mempty  = MInt 0-  mappend :: MInt -> MInt -> MInt   mappend = (<>) -size :: Foldable t => t -> Integer+size :: Visitable t => t -> Integer size t    = n   where     MInt n = fold szV () mempty t-    szV    = (defaultFolder :: Folder MInt t) { accExpr = \ _ _ -> MInt 1 }+    szV    = (defaultVisitor :: Visitor MInt t) { accExpr = \ _ _ -> MInt 1 }  -lamSize :: Foldable t => t -> Integer+lamSize :: Visitable t => t -> Integer lamSize t    = n   where     MInt n = fold szV () mempty t-    szV    = (defaultFolder :: Folder MInt t) { accExpr = accum }+    szV    = (defaultVisitor :: Visitor MInt t) { accExpr = accum }     accum _ (ELam _ _) = MInt 1     accum _ _          = MInt 0 -eapps :: Foldable t => t -> [Expr]+eapps :: Visitable t => t -> [Expr] eapps                 = fold eappVis () []   where-    eappVis              = (defaultFolder :: Folder [KVar] t) { accExpr = eapp' }+    eappVis              = (defaultVisitor :: Visitor [KVar] t) { accExpr = eapp' }     eapp' _ e@(EApp _ _) = [e]     eapp' _ _            = []  {-# SCC kvarsExpr #-}-kvarsExpr :: ExprV v -> [KVar]+kvarsExpr :: Expr -> [KVar] kvarsExpr = go []   where     go acc e0 = case e0 of       ESym _ -> acc       ECon _ -> acc       EVar _ -> acc-      PKVar k _ _ -> k : 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@@ -483,18 +350,17 @@       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-      ELet _ 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 a -> c a -> [KVar]+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       = kvarsExpr . reftPred . sr_reft -envKVarsN :: (TaggedC c a) => BindEnv a -> c a -> [(KVar, Int)]+envKVarsN :: (TaggedC c a) => BindEnv -> c a -> [(KVar, Int)] envKVarsN be c = tally [ kvs sr |  (_, sr) <- clhs be c]   where     tally      = Misc.count . concat@@ -510,8 +376,9 @@ isConcC = all isConc . conjuncts . crhs  isKvar :: Expr -> Bool-isKvar PKVar{} = True-isKvar _       = False+isKvar (PKVar {}) = True+isKvar (PGrad {}) = True+isKvar _          = False  isConc :: Expr -> Bool isConc = null . kvarsExpr@@ -533,46 +400,19 @@ --   to the ty-vars that they should be substituted with. Note the --   domain and range are both Symbol and not the Int used for real ty-vars. ---------------------------------------------------------------------------------type CoSub = M.HashMap Symbol Sort+type CoSub = M.HashMap Symbol Sort   applyCoSub :: CoSub -> Expr -> Expr-applyCoSub coSub-   | M.null coSub = id-   | otherwise = mapExprOnExpr fE+applyCoSub coSub      = mapExpr fE   where     fE (ECoerc s t e) = ECoerc  (txS s) (txS t) e     fE (ELam (x,t) e) = ELam (x, txS t)         e-    fE (ECst e t)     = ECst e (txS t)-    fE (PExist xts p) = PExist (map (fmap txS) xts) (fE p)-    fE (PAll xts p) = PAll (map (fmap txS) xts) (fE p)     fE e              = e-    txS               = mapSortOnlyOnce fS-    fS (FObj a)       = {- FObj -} txV a+    txS               = mapSort fS+    fS (FObj a)       = {- FObj -} (txV a)     fS t              = t     txV a             = M.lookupDefault (FObj a) a coSub --type CoSubV = M.HashMap Sort Sort--applyCoSubV :: CoSubV -> Expr -> Expr-applyCoSubV coSub = mapExprOnExpr fE-  where-    fE (ECoerc s t e) = ECoerc  (txS s) (txS t) e-    fE (ELam (x,t) e) = ELam (x, txS t)         e-    fE (ECst e t)     = ECst e (txS t)-    fE e              = e--    txS               = mapSortOnlyOnce fS--    fS t              = M.lookupDefault t t coSub--applyCoercion :: Symbol -> Sort -> Sort -> Sort-applyCoercion a t = mapSortOnlyOnce f-  where-    f (FObj b)-      | a == b    = t-    f s           = s- --------------------------------------------------------------------------------- -- | Visitors over @Sort@ ---------------------------------------------------------------------------------@@ -585,31 +425,13 @@     go b (FAbs _ t)    = go b t     go b _             = b --- | Like 'mapSort' but it doesn't substitute on the result--- of the function.------ > mapSortOnlyOnce [(a,b), (b,c)] a = b------ whereas------ > mapSort [(a,b), (b,c)] a = c----mapSortOnlyOnce :: (Sort -> Sort) -> Sort -> Sort-mapSortOnlyOnce f = step-  where-    step !x           = f $ go x-    go (FFunc t1 t2) = FFunc (step t1) (step t2)-    go (FApp t1 t2)  = FApp  (step t1) (step t2)-    go (FAbs i t)    = FAbs i (step t)-    go !t             = t- mapSort :: (Sort -> Sort) -> Sort -> Sort mapSort f = step   where     step !x           = go (f x)-    go (FFunc t1 t2) = FFunc (step t1) (step t2)-    go (FApp t1 t2)  = FApp  (step t1) (step t2)-    go (FAbs i t)    = FAbs i (step t)+    go !(FFunc t1 t2) = FFunc (step t1) (step t2)+    go !(FApp t1 t2)  = FApp  (step t1) (step t2)+    go !(FAbs i t)    = FAbs i (step t)     go !t             = t  foldDataDecl :: (a -> Sort -> a) -> a -> DataDecl -> a@@ -632,28 +454,28 @@   instance SymConsts a => SymConsts [a] where-  symConsts xs = concatMap symConsts xs--instance SymConsts AxiomEnv where+  symConsts xs = concatMap symConsts xs +  +instance SymConsts AxiomEnv where    symConsts xs =  symConsts (aenvEqs xs) ++ symConsts (aenvSimpl xs) -instance SymConsts Equation where-  symConsts = symConsts . eqBody+instance SymConsts Equation where +  symConsts = symConsts . eqBody  -instance SymConsts Rewrite where-  symConsts = symConsts . smBody+instance SymConsts Rewrite where +  symConsts = symConsts . smBody    -- instance  SymConsts (FInfo a) where instance (SymConsts (c a)) => SymConsts (GInfo c a) where   symConsts fi = Misc.sortNub $ csLits ++ bsLits ++ qsLits     where-      csLits   = concatMap symConsts $ M.elems $ cm    fi-      bsLits   = symConsts                     $ bs    fi-      qsLits   = concatMap (symConsts . qBody) $ quals fi+      csLits   = concatMap symConsts $ M.elems  $  cm    fi+      bsLits   = symConsts           $ bs                fi+      qsLits   = concatMap symConsts $ qBody   <$> quals fi -instance SymConsts (BindEnv a) where-  symConsts    = concatMap (symConsts . Misc.snd3) . M.elems . beBinds+instance SymConsts BindEnv where+  symConsts    = concatMap (symConsts . snd) . M.elems . beBinds  instance SymConsts (SubC a) where   symConsts c  = symConsts (slhs c) ++@@ -672,20 +494,9 @@ instance SymConsts Expr where   symConsts = getSymConsts -getSymConsts :: Foldable t => t -> [SymConst]+getSymConsts :: Visitable t => t -> [SymConst] getSymConsts         = fold scVis () []   where-    scVis            = (defaultFolder :: Folder [SymConst] t)  { accExpr = sc }+    scVis            = (defaultVisitor :: Visitor [SymConst] t)  { accExpr = sc }     sc _ (ESym c)    = [c]     sc _ _           = []--getConstants' :: Foldable t => t -> [Constant]-getConstants' = nubOrd . fold cVis () []-  where-    cVis           = (defaultFolder :: Folder [Constant] t) { accExpr = ac }-    ac _ (ECon c)  = [c]-    ac _ _         = []---- | getConstants returns both the vanilla constants AND the sym-constants as str-literals-getConstants :: Foldable t => t -> [Constant]-getConstants z = nubOrd $ getConstants' z ++ [ L t strSort | SL t <- getSymConsts z]
src/Language/Fixpoint/Utils/Builder.hs view
@@ -3,10 +3,12 @@ -- | Wrapper around `Data.Text.Builder` that exports some useful combinators  module Language.Fixpoint.Utils.Builder-  ( fromText+  ( Builder+  , fromLazyText   , fromString+  , fromText+  , toLazyText   , parens-  , quotes   , (<+>)   , parenSeqs   , seqs@@ -15,28 +17,50 @@   , key3   , bShow   , bFloat+  , bb+  , lbb+  , blt   ) where -import           Data.Foldable (fold) import           Data.String-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as B+import qualified Data.Text.Lazy.Builder as B+import qualified Data.Text.Lazy         as LT import qualified Data.Text              as T-import qualified Data.Text.Encoding     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 t = B.byteString $ T.encodeUtf8 t+fromText = Leaf . B.fromText  parens :: Builder -> Builder parens b = "(" <>  b <> ")" -quotes :: Builder -> Builder-quotes b = "\"" <> b <> "\""--infixl 9 <+> (<+>) :: Builder -> Builder -> Builder x <+> y = x <> " " <> y @@ -53,10 +77,20 @@ key3 k b1 b2 b3 = parenSeqs [k, b1, b2, b3]  seqs :: [Builder] -> Builder-seqs = fold . L.intersperse " "+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
@@ -13,9 +13,7 @@     Ext (..)   , extFileName   , extFileNameR-  , extFileNameR'   , tempDirectory-  , tempFileName   , extModuleName   , withExt   , isExtFile@@ -76,7 +74,7 @@          | Js       -- ^ JavaScript source          | Ts       -- ^ Typescript source          | Spec     -- ^ Spec file (e.g. include/Prelude.spec)-         | BinSpec  -- ^ Lifted-Spec file, containing automatically generated specifications+         | BinSpec  -- ^ Lifted-Spec file, containing automatically generated specifications           | Hquals   -- ^ Qualifiers file (e.g. include/Prelude.hquals)          | Result   -- ^ Final result: SAFE/UNSAFE          | Cst      -- ^ HTML file with templates?@@ -93,7 +91,6 @@          | BinFq    -- ^ Binary representation of .fq / FInfo          | Smt2     -- ^ SMTLIB2 query file          | HSmt2    -- ^ Horn query file-         | HJSON    -- ^ Horn query JSON file          | Min      -- ^ filter constraints with delta debug          | MinQuals -- ^ filter qualifiers with delta debug          | MinKVars -- ^ filter kvars with delta debug@@ -127,7 +124,6 @@     go Cache    = ".err"     go Smt2     = ".smt2"     go HSmt2    = ".horn.smt2"-    go HJSON    = ".horn.json"     go (Auto n) = ".auto." ++ show n     go Dot      = ".dot"     go BinFq    = ".bfq"@@ -141,10 +137,11 @@ withExt f ext   =  replaceExtension f (extMap ext)  extFileName     :: Ext -> FilePath -> FilePath-extFileName e f = tempFileName (addExtension f (extMap e))--tempFileName     :: FilePath -> FilePath-tempFileName f = tempDirectory f </> takeFileName f+extFileName e f = path </> addExtension file ext+  where+    path        = tempDirectory f+    file        = takeFileName  f+    ext         = extMap e  tempDirectory   :: FilePath -> FilePath tempDirectory f@@ -159,12 +156,6 @@  extFileNameR     :: Ext -> FilePath -> FilePath extFileNameR ext = (`addExtension` extMap ext)---- | Like 'extFileName' but uses a custom output directory when provided.--- When 'Nothing', falls back to the default @.liquid/@ directory behavior.-extFileNameR' :: Maybe FilePath -> Ext -> FilePath -> FilePath-extFileNameR' Nothing  e f = extFileName e f-extFileNameR' (Just d) e f = d </> takeFileName (addExtension f (extMap e))  isExtFile ::  Ext -> FilePath -> Bool isExtFile ext = (extMap ext ==) . takeExtension
src/Language/Fixpoint/Utils/Trie.hs view
@@ -1,4 +1,4 @@-module Language.Fixpoint.Utils.Trie+module Language.Fixpoint.Utils.Trie    ( -- * Datatype     Trie (..)   , Branch (..)@@ -8,75 +8,75 @@   , insert   , fromList -    -- * Visitors-  , fold+    -- * Visitors +  , fold    , foldM-  )-  where+  ) +  where  -import qualified Data.List as L-import Language.Fixpoint.Types.PrettyPrint+import qualified Data.List as L +import Language.Fixpoint.Types.PrettyPrint   import qualified Language.Fixpoint.Misc as Misc  type Key  = Int type Path = [Key] -newtype Trie a-  = Node [Branch a]+data Trie a +  = Node ![Branch a]   deriving (Eq, Show) -data Branch a+data Branch a    = Bind !Key !(Trie a)-  | Val a+  | Val a    deriving (Eq, Show)  --------------------------------------------------------------------------------empty :: Trie a+empty :: Trie a  ------------------------------------------------------------------------------- empty = Node []  --------------------------------------------------------------------------------insert :: Path -> a -> Trie a -> Trie a+insert :: Path -> a -> Trie a -> Trie a  --------------------------------------------------------------------------------insert []     v (Node ts) = Node (Val v : ts)+insert []     v (Node ts) = Node ((Val v) : ts)  insert (i:is) v (Node ts) = Node (insertKey i is v ts)   --------------------------------------------------------------------------------fromList :: [(Path, a)] -> Trie a+fromList :: [(Path, a)] -> Trie a  --------------------------------------------------------------------------------fromList = L.foldl' (\t (k, v) -> insert k v t) empty---- i=3--- 0 1 2 3 4 5 6+fromList = L.foldl' (\t (k, v) -> insert k v t) empty  +-- i=3 +-- 0 1 2 3 4 5 6 +   insertKey :: Key -> Path -> a -> [Branch a] -> [Branch a]-insertKey i is v bs@((Bind j tj) : bs')-  | i == j              = Bind i (insert is v tj) : bs'-  | i <  j              = Bind i (pathTrie is v)  : bs-insertKey i is v (b:bs) = b : insertKey i is v bs-insertKey i is v []     = [ Bind i (pathTrie is v) ]+insertKey i is v bs@((Bind j tj) : bs') +  | i == j              = Bind i (insert is v tj) : bs' +  | i <  j              = Bind i (pathTrie is v)  : bs +insertKey i is v (b:bs) = b : insertKey i is v bs +insertKey i is v []     = [ Bind i (pathTrie is v) ]  -pathTrie :: Path -> a -> Trie a-pathTrie []     v = Node [Val v]+pathTrie :: Path -> a -> Trie a +pathTrie []     v = Node [Val v]  pathTrie (i:is) v = Node [Bind i (pathTrie is v)]  --------------------------------------------------------------------------------fold :: (acc -> Path -> a -> acc) -> acc -> Trie a -> acc+fold :: (acc -> Path -> a -> acc) -> acc -> Trie a -> acc  ------------------------------------------------------------------------------- fold = undefined  --------------------------------------------------------------------------------foldM :: (Monad m) => (acc -> Path -> a -> m acc) -> acc -> Trie a -> m acc+foldM :: (Monad m) => (acc -> Path -> a -> m acc) -> acc -> Trie a -> m acc  ------------------------------------------------------------------------------- foldM = undefined  -instance Show a => PPrint (Trie a) where-  pprintTidy _ = Misc.tshow+instance Show a => PPrint (Trie a) where +  pprintTidy _ = Misc.tshow   -{-+{-        e1         <----@@ -108,14 +108,14 @@  as the `trie` -     1 -> 2 -----------> A+     1 -> 2 -----------> A             `-> 3 -> 4 -> B      |         ` -> 5 -> C      `-> 6 ------------> D  -} --- >>> _example0 == _example1+-- >>> _example0 == _example1  -- True  _example0 :: Trie Char@@ -126,7 +126,7 @@     n3   = Node [Bind 4 n4, Bind 5 n5]     n4   = Node [Val 'B']     n5   = Node [Val 'C']-    n6   = Node [Val 'D']+    n6   = Node [Val 'D']    _example1 :: Trie Char
− src/Language/Fixpoint/Verbosity.hs 
@@ -1,45 +0,0 @@--- | Global verbosity IORef, replacing the one provided by @cmdargs@.---   Use 'setVerbosity' after option parsing to control all 'whenLoud' /---   'whenNormal' guards throughout the solver.-module Language.Fixpoint.Verbosity-  ( Verbosity (..)-  , setVerbosity-  , getVerbosity-  , whenLoud-  , whenNormal-  , isNormal-  , isLoud-  ) where--import Control.Monad      (when)-import Data.IORef         (IORef, newIORef, readIORef, writeIORef)-import System.IO.Unsafe   (unsafePerformIO)--data Verbosity = Quiet | Normal | Loud-  deriving (Eq, Ord, Show)--{-# NOINLINE verbosityRef #-}-verbosityRef :: IORef Verbosity-verbosityRef = unsafePerformIO (newIORef Normal)--setVerbosity :: Verbosity -> IO ()-setVerbosity = writeIORef verbosityRef--getVerbosity :: IO Verbosity-getVerbosity = readIORef verbosityRef--whenLoud :: IO () -> IO ()-whenLoud act = do-  v <- getVerbosity-  when (v >= Loud) act--whenNormal :: IO () -> IO ()-whenNormal act = do-  v <- getVerbosity-  when (v >= Normal) act--isNormal :: IO Bool-isNormal = (>= Normal) <$> getVerbosity--isLoud :: IO Bool-isLoud = (>= Loud) <$> getVerbosity
+ 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/ebind-00.fq view
@@ -0,0 +1,16 @@+fixpoint "--eliminate=all"++// bind  0 x1 : {v: int | v = 10 }+ebind 0 x1 : { int }++constraint:+  env [0]+  lhs {v1 : int | v1 = 10}+  rhs {v1 : int | v1 = x1}+  id 1 tag []++constraint:+  env [0]+  lhs {v2 : int | v2 = x1 + 1 }+  rhs {v2 : int | v2 = 110    }+  id 2 tag []
+ tests/neg/ebind-01.fq view
@@ -0,0 +1,17 @@+fixpoint "--eliminate=all"++bind  1 m  : {v: int | true }+ebind 2 x1 : { int }+// bind  2 x1 : {v: int | v = m + 1 }++constraint:+  env [1; 2]+  lhs {v : int | v = m + 1 }+  rhs {v : int | v = x1    }+  id 1 tag []++constraint:+  env [1; 2]+  lhs {v : int | v = x1 + 1}+  rhs {v : int | v = 20 + m }+  id 2 tag []
+ tests/neg/ebind-02.fq view
@@ -0,0 +1,28 @@+fixpoint "--eliminate=all"++bind  0 m  : {v: int | true }+bind  1 z  : {v: int | v = m - 1 }+ebind 2 x1 : { int }+// bind  2 x1 : {v: int | v = m + 1 }++constraint:+  env [0; 1]+  lhs {v : int | v = z + 2 }+  rhs {v : int | $k         }+  id 1 tag []++constraint:+  env [0; 2]+  lhs {v : int | $k      }+  rhs {v : int | v = x1 }+  id 2 tag []++constraint:+  env [0; 2]+  lhs {v : int | v = x1 + 1 }+  rhs {v : int | v = m  + 20 }+  id 3 tag []++wf: +  env [0]+  reft {v:int | [$k] }
+ tests/neg/ebind-03.fq view
@@ -0,0 +1,45 @@+fixpoint "--eliminate=all"++ebind 1 x1 : { int }+ebind 2 x2 : { int }+++constraint:+  env [1]+  lhs {v : int | v = 1  }+  rhs {v : int | v = x1 }+  id 1 tag []++constraint:+  env [1]+  lhs {v : int | v = x1 + 1 }+  rhs {v : int | $ka        }+  id 2 tag []++constraint:+  env [2]+  lhs {v : int | $ka    }+  rhs {v : int | v = x2 }+  id 3 tag []++constraint:+  env [2]+  lhs {v : int | v = x2 + 1}+  rhs {v : int | $kb       }+  id 4 tag []++constraint:+  env []+  lhs {v : int | $kb   }+  rhs {v : int | v = 30 } +  id 5 tag []+++wf: +  env []+  reft {v:int | [$ka] }++wf: +  env []+  reft {v:int | [$kb] }+
+ tests/neg/ebind-04.fq view
@@ -0,0 +1,35 @@+fixpoint "--eliminate=all"++ebind 1 x : { int }++constraint:+  env [1]+  lhs {v : int | $k1   }+  rhs {v : int | v = x }+  id 1 tag []++constraint:+  env [1]+  lhs {v : int | v = x + 1 }+  rhs {v : int | $k2       }+  id 2 tag []++constraint:+  env []+  lhs {v : int | v = 3 }+  rhs {v : int | $k1   }+  id 3 tag []++constraint:+  env []+  lhs {v : int | $k2   }+  rhs {v : int | v = 40 }+  id 4 tag []++wf: +  env []+  reft {v:int | [$k1] }++wf: +  env []+  reft {v:int | [$k2] }
+ tests/neg/ebind-elim2.fq view
@@ -0,0 +1,26 @@+bind  1 a    : { a : int | true }+ebind 2 c    : { int }++wf:+  env [1]+  reft {VV##1 : Tuple | [$k_##1]}++constraint:+  env [1;2]+  lhs {VV##F##4 : int | VV##F##4 = c }+  rhs {VV##F##4 : int | $k_##1[VV##1 := VV##F##4] }+  id 1 tag []++constraint:+  env [1;2]+  lhs {VV##F##5 : int | $k_##1[VV##1:=VV##F##5] }+  rhs {VV##F##5 : int | VV##F##5 = c }+  id 2 tag []++// The following constraint is needed only to prevent eliminate's **sharing** optimization.++constraint:+  env []+  lhs {VV##F##6 : int | $k_##1[VV##1:=VV##F##6] }+  rhs {VV##F##6 : int | VV##F##6 = 0 }+  id 3 tag []
tests/neg/elim-dep-00.fq view
@@ -1,7 +1,7 @@ -qualif False(v:int)  { 0 = 1 }-qualif Zero(v:int)  { 0 = v }-qualif One(v:int)  { 1 = v }+qualif False(v:int) : (0 = 1)+qualif Zero(v:int) : (0 = v)+qualif One(v:int) : (1 = v)  bind 1 x : {v:int | $k2 }
− tests/neg/localrw.fq 
@@ -1,16 +0,0 @@-fixpoint "--localrewrites"-fixpoint "--rewrite"-fixpoint "--allowho"--bind 1 g : { V : Int | true }-bind 2 g : { V : Int | true }--defineLocal 1 [g := (40 + 1)]--expand [1 : True]--constraint:-    env [2]-    lhs { V : Tuple | true }-    rhs { V : Tuple | (g = 41) }-    id 1 tag []
tests/neg/maps.fq view
@@ -1,30 +1,37 @@  bind 1 m1 : {v : Map_t Int Int | v = Map_default 0}-bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) }-bind 3 m3 : {v : Map_t Int Int | v = (Map_store (Map_store m1 20 1) 10 1) }-bind 4 m4 : {v : Map_t Int Int | v = (Map_store m1 10 1) }-bind 5 m5 : {v : Map_t Int Int | v = (Map_store m1 20 1) }+bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) } +bind 3 m3 : {v : Map_t Int Int | v = (Map_store (Map_store m1 20 1) 10 1) } +bind 4 m4 : {v : Map_t Int Int | v = (Map_store m1 10 1) } +bind 5 m5 : {v : Map_t Int Int | v = (Map_store m1 20 1) }   constraint:   env [ 1 ]   lhs {v : int | v = Map_select m1 100 }-  rhs {v : int | v = 0 }+  rhs {v : int | v = 0 }    id 1 tag []  constraint:   env [ 1; 2 ]   lhs {v : int | v = Map_select m2 100 }-  rhs {v : int | v = 0 }+  rhs {v : int | v = 0 }    id 2 tag []  constraint:   env [ 1; 2 ]   lhs {v : int | v = Map_select m2 10 }-  rhs {v : int | v = 1 }+  rhs {v : int | v = 1 }    id 3 tag []  constraint:   env [ 1; 2; 3 ]   lhs {v : int | true }-  rhs {v : int | m4 = m5 }+  rhs {v : int | m2 = m3 }    id 4 tag []++constraint:+  env [ 1; 2; 3; 4; 5 ]+  lhs {v : int | true }+  rhs {v : int | m2 = Map_union m4 m4 } +  id 5 tag []+
− tests/neg/maps02.fq 
@@ -1,9 +0,0 @@-bind 1 m1 : {v : Map_t Int Int | v = Map_default 0}-bind 2 s1 : {v : Set_Set Int | v = (Set_cup (Set_sng 10) (Set_sng 30))}-bind 3 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) } --constraint:-  env [ 1; 2; 3 ]-  lhs {v : Set_Set Int | v = Map_to_set m2 }-  rhs {v : Set_Set Int | v = s1 } -  id 1 tag []
− tests/neg/numeric-version.fq 
@@ -1,1 +0,0 @@-fixpoint "--numeric-version"
tests/neg/qualif-template-00.fq view
@@ -1,4 +1,4 @@-qualif Prefix(v:a, z as (moon . $1) : b)  { v = z }+qualif Prefix(v:a, z as (moon . $1) : b) : (v = z)  bind 0  monday  : {v : int | true} bind 10 tuesday : {v : int | true}
tests/neg/qualif-template-01.fq view
@@ -1,6 +1,6 @@ // qualif Goob(v:a, z: b) : (v = z) // qualif Prefix2(v:a, x as (mon . $1) : b, y as (sun . $1)) : (v = x + y)-qualif Prefix(v:a, z as ($1 . sday) : b)  { v = z }+qualif Prefix(v:a, z as ($1 . sday) : b) : (v = z)  bind 0  monday  : {v : int | true} bind 10 tuesday : {v : int | true}
tests/neg/qualif-template-02.fq view
@@ -1,6 +1,6 @@ fixpoint "--eliminate=none" -qualif Prefix2(v:a, x as (sun . $1)  : b, y as (tues . $1) : b)  { v = x + y }+qualif Prefix2(v:a, x as (sun . $1)  : b, y as (tues . $1) : b) : (v = x + y)  bind 0  sunday  : {v : int | v = 6  } bind 1  monday  : {v : int | v = 4  }
tests/neg/test00.fq view
@@ -1,6 +1,6 @@ -qualif Zog(v:a)  { 10 <= v }-qualif Bog(v:a, x:a)  { x <= v }+qualif Zog(v:a) : (10 <= v)+qualif Bog(v:a, x:a) : (x <= v)  bind 0 a : {v: int | $k0}
tests/neg/test00.hs.fq view
@@ -1,51 +1,51 @@-qualif Fst(v : @(1), y : @(0)) { v = fst([y])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 29, column 8)-qualif Snd(v : @(1), y : @(0)) { v = snd([y])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 30, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { (Prop([v])) <=> (len([xs]) > 0)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 13, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { (Prop([v])) <=> (len([xs]) = 0)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 14, column 8)-qualif ListZ(v : [@(0)]) { len([v]) = 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 16, column 8)-qualif ListZ(v : [@(0)]) { len([v]) >= 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 17, column 8)-qualif ListZ(v : [@(0)]) { len([v]) > 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 18, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) = len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 20, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) >= len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 21, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) > len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 22, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) <= len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 23, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) < len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 24, column 8)-qualif EqLen(v : int, xs : [@(0)]) { v = len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 26, column 8)-qualif LenEq(v : [@(0)], x : int) { x = len([v])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 27, column 8)-qualif LenDiff(v : [@(0)], x : int) { len([v]) = (x + 1)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 28, column 8)-qualif LenDiff(v : [@(0)], x : int) { len([v]) = (x - 1)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 29, column 8)-qualif LenAcc(v : int, xs : [@(0)], n : int) { v = (len([xs]) + n)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 30, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 3, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 4, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 5, column 8)-qualif Bot(v : bool) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 6, column 8)-qualif Bot(v : int) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 7, column 8)-qualif CmpZ(v : @(0)) { v < 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 9, column 8)-qualif CmpZ(v : @(0)) { v <= 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 10, column 8)-qualif CmpZ(v : @(0)) { v > 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 11, column 8)-qualif CmpZ(v : @(0)) { v >= 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 12, column 8)-qualif CmpZ(v : @(0)) { v = 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 13, column 8)-qualif CmpZ(v : @(0)) { v != 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 14, column 8)-qualif Cmp(v : @(0), x : @(0)) { v < x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 16, column 8)-qualif Cmp(v : @(0), x : @(0)) { v <= x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 17, column 8)-qualif Cmp(v : @(0), x : @(0)) { v > x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 18, column 8)-qualif Cmp(v : @(0), x : @(0)) { v >= x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 19, column 8)-qualif Cmp(v : @(0), x : @(0)) { v = x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 20, column 8)-qualif Cmp(v : @(0), x : @(0)) { v != x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 21, column 8)-qualif One(v : int) { v = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 28, column 8)-qualif True(v : bool) { v  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 29, column 8)-qualif False(v : bool) { ~ ((v))  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 30, column 8)-qualif True1(v : GHC.Types.Bool) { Prop([v])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 31, column 8)-qualif False1(v : GHC.Types.Bool) { ~ ((Prop([v])))  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 32, column 8)-qualif Papp(v : @(0), p : (Pred  @(0))) { (papp1([p;-                                                   v])) } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 35, column 8)-qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))) { (papp2([p;+qualif Fst(v : @(1), y : @(0)): (v = fst([y])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 29, column 8)+qualif Snd(v : @(1), y : @(0)): (v = snd([y])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 30, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((? Prop([v])) <=> (len([xs]) > 0)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 13, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((? Prop([v])) <=> (len([xs]) = 0)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 14, column 8)+qualif ListZ(v : [@(0)]): (len([v]) = 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 16, column 8)+qualif ListZ(v : [@(0)]): (len([v]) >= 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 17, column 8)+qualif ListZ(v : [@(0)]): (len([v]) > 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 18, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) = len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 20, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) >= len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 21, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) > len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 22, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) <= len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 23, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) < len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 24, column 8)+qualif EqLen(v : int, xs : [@(0)]): (v = len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 26, column 8)+qualif LenEq(v : [@(0)], x : int): (x = len([v])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 27, column 8)+qualif LenDiff(v : [@(0)], x : int): (len([v]) = (x + 1)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 28, column 8)+qualif LenDiff(v : [@(0)], x : int): (len([v]) = (x - 1)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 29, column 8)+qualif LenAcc(v : int, xs : [@(0)], n : int): (v = (len([xs]) + n)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 30, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 3, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 4, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 5, column 8)+qualif Bot(v : bool): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 6, column 8)+qualif Bot(v : int): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 7, column 8)+qualif CmpZ(v : @(0)): (v < 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 9, column 8)+qualif CmpZ(v : @(0)): (v <= 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 10, column 8)+qualif CmpZ(v : @(0)): (v > 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 11, column 8)+qualif CmpZ(v : @(0)): (v >= 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 12, column 8)+qualif CmpZ(v : @(0)): (v = 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 13, column 8)+qualif CmpZ(v : @(0)): (v != 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 14, column 8)+qualif Cmp(v : @(0), x : @(0)): (v < x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 16, column 8)+qualif Cmp(v : @(0), x : @(0)): (v <= x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 17, column 8)+qualif Cmp(v : @(0), x : @(0)): (v > x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 18, column 8)+qualif Cmp(v : @(0), x : @(0)): (v >= x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 19, column 8)+qualif Cmp(v : @(0), x : @(0)): (v = x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 20, column 8)+qualif Cmp(v : @(0), x : @(0)): (v != x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 21, column 8)+qualif One(v : int): (v = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 28, column 8)+qualif True(v : bool): (? v) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 29, column 8)+qualif False(v : bool): (~ ((? v))) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 30, column 8)+qualif True1(v : GHC.Types.Bool): (? Prop([v])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 31, column 8)+qualif False1(v : GHC.Types.Bool): (~ ((? Prop([v])))) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 32, column 8)+qualif Papp(v : @(0), p : (Pred  @(0))): (? papp1([p;+                                                   v])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 35, column 8)+qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))): (? papp2([p;                                                                     v;-                                                                    x])) } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 38, column 8)-qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))) { (papp3([p;+                                                                    x])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 38, column 8)+qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))): (? papp3([p;                                                                                     v;                                                                                     x;-                                                                                    y])) } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 41, column 8)+                                                                                    y])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 41, column 8)   @@ -137,33 +137,33 @@ bind 3 GHC.Types.EQ$35$6U : {VV$35$167 : GHC.Types.Ordering | [(VV$35$167 = GHC.Types.EQ$35$6U)]} bind 4 GHC.Types.LT$35$6S : {VV$35$168 : GHC.Types.Ordering | [(VV$35$168 = GHC.Types.LT$35$6S)]} bind 5 GHC.Types.GT$35$6W : {VV$35$169 : GHC.Types.Ordering | [(VV$35$169 = GHC.Types.GT$35$6W)]}-bind 6 GHC.Types.True$35$6u : {v$35$4 : GHC.Types.Bool | [(Prop([v$35$4]))]}-bind 7 GHC.Types.False$35$68 : {v$35$5 : GHC.Types.Bool | [(~ ((Prop([v$35$5]))))]}-bind 8 GHC.Types.False$35$68 : {v$35$5 : GHC.Types.Bool | [(~ ((Prop([v$35$5]))))]}+bind 6 GHC.Types.True$35$6u : {v$35$4 : GHC.Types.Bool | [(? Prop([v$35$4]))]}+bind 7 GHC.Types.False$35$68 : {v$35$5 : GHC.Types.Bool | [(~ ((? Prop([v$35$5]))))]}+bind 8 GHC.Types.False$35$68 : {v$35$5 : GHC.Types.Bool | [(~ ((? Prop([v$35$5]))))]} bind 9 GHC.Types.$91$$93$$35$6m : {VV : func(1, [[@(0)]]) | []}-bind 10 GHC.Types.True$35$6u : {v$35$4 : GHC.Types.Bool | [(Prop([v$35$4]))]}+bind 10 GHC.Types.True$35$6u : {v$35$4 : GHC.Types.Bool | [(? Prop([v$35$4]))]} bind 11 GHC.Types.GT$35$6W : {VV$35$214 : GHC.Types.Ordering | [(cmp([VV$35$214]) = GHC.Types.GT$35$6W)]} bind 12 GHC.Types.LT$35$6S : {VV$35$215 : GHC.Types.Ordering | [(cmp([VV$35$215]) = GHC.Types.LT$35$6S)]} bind 13 GHC.Types.EQ$35$6U : {VV$35$216 : GHC.Types.Ordering | [(cmp([VV$35$216]) = GHC.Types.EQ$35$6U)]} bind 14 GHC.Base.Nothing$35$r1d : {VV : func(1, [(GHC.Base.Maybe  @(0))]) | []} bind 15 z$35$a10N : {VV$35$221 : int | [$k_$35$222]} bind 16 lq_anf$36$_d116 : {lq_tmp$36$x$35$229 : int | [(lq_tmp$36$x$35$229 = (100  :  int))]}-bind 17 lq_anf$36$_d117 : {lq_tmp$36$x$35$236 : GHC.Types.Bool | [((Prop([lq_tmp$36$x$35$236])) <=> (z$35$a10N >= lq_anf$36$_d116))]}+bind 17 lq_anf$36$_d117 : {lq_tmp$36$x$35$236 : GHC.Types.Bool | [((? Prop([lq_tmp$36$x$35$236])) <=> (z$35$a10N >= lq_anf$36$_d116))]} bind 18 lq_anf$36$_d118 : {lq_tmp$36$x$35$254 : int | [(lq_tmp$36$x$35$254 = (0  :  int))]} bind 19 Test0.x$35$rYP : {VV$35$250 : int | [$k_$35$251]} bind 20 lq_anf$36$_d119 : {lq_tmp$36$x$35$269 : int | [(lq_tmp$36$x$35$269 = (0  :  int))]}-bind 21 lq_anf$36$_d11a : {lq_tmp$36$x$35$275 : GHC.Types.Bool | [((Prop([lq_tmp$36$x$35$275])) <=> (Test0.x$35$rYP > lq_anf$36$_d119))]}+bind 21 lq_anf$36$_d11a : {lq_tmp$36$x$35$275 : GHC.Types.Bool | [((? Prop([lq_tmp$36$x$35$275])) <=> (Test0.x$35$rYP > lq_anf$36$_d119))]} bind 22 lq_anf$36$_d11b : {lq_tmp$36$x$35$291 : GHC.Types.Bool | [(lq_tmp$36$x$35$291 = lq_anf$36$_d11a)]} bind 23 lq_anf$36$_d11b : {lq_tmp$36$x$35$293 : GHC.Types.Bool | [(lq_tmp$36$x$35$293 = lq_anf$36$_d11a)]} bind 24 lq_anf$36$_d11b : {lq_tmp$36$x$35$293 : GHC.Types.Bool | [(lq_tmp$36$x$35$293 = lq_anf$36$_d11a);-                                                                  (~ ((Prop([lq_tmp$36$x$35$293]))));-                                                                  (~ ((Prop([lq_tmp$36$x$35$293]))));-                                                                  (~ ((Prop([lq_tmp$36$x$35$293]))))]}+                                                                  (~ ((? Prop([lq_tmp$36$x$35$293]))));+                                                                  (~ ((? Prop([lq_tmp$36$x$35$293]))));+                                                                  (~ ((? Prop([lq_tmp$36$x$35$293]))))]} bind 25 lq_anf$36$_d11b : {lq_tmp$36$x$35$299 : GHC.Types.Bool | [(lq_tmp$36$x$35$299 = lq_anf$36$_d11a)]} bind 26 lq_anf$36$_d11b : {lq_tmp$36$x$35$299 : GHC.Types.Bool | [(lq_tmp$36$x$35$299 = lq_anf$36$_d11a);-                                                                  (Prop([lq_tmp$36$x$35$299]));-                                                                  (Prop([lq_tmp$36$x$35$299]));-                                                                  (Prop([lq_tmp$36$x$35$299]))]}+                                                                  (? Prop([lq_tmp$36$x$35$299]));+                                                                  (? Prop([lq_tmp$36$x$35$299]));+                                                                  (? Prop([lq_tmp$36$x$35$299]))]} bind 27 Test0.prop_abs$35$r10h : {VV$35$265 : GHC.Types.Bool | [$k_$35$266]} bind 28 VV$35$310 : {VV$35$310 : GHC.Types.Bool | [$k_$35$226[lq_tmp$36$x$35$307:=Test0.x$35$rYP][lq_tmp$36$x$35$305:=VV$35$310][VV$35$225:=VV$35$310][z$35$a10N:=Test0.x$35$rYP]]} bind 29 VV$35$310 : {VV$35$310 : GHC.Types.Bool | [$k_$35$226[lq_tmp$36$x$35$307:=Test0.x$35$rYP][lq_tmp$36$x$35$305:=VV$35$310][VV$35$225:=VV$35$310][z$35$a10N:=Test0.x$35$rYP]]}@@ -183,8 +183,8 @@ bind 43 VV$35$331 : {VV$35$331 : int | [(VV$35$331 = lq_anf$36$_d118)]} bind 44 VV$35$334 : {VV$35$334 : int | [(VV$35$334 = 0)]} bind 45 VV$35$334 : {VV$35$334 : int | [(VV$35$334 = 0)]}-bind 46 VV$35$337 : {VV$35$337 : GHC.Types.Bool | [(Prop([VV$35$337]))]}-bind 47 VV$35$337 : {VV$35$337 : GHC.Types.Bool | [(Prop([VV$35$337]))]}+bind 46 VV$35$337 : {VV$35$337 : GHC.Types.Bool | [(? Prop([VV$35$337]))]}+bind 47 VV$35$337 : {VV$35$337 : GHC.Types.Bool | [(? Prop([VV$35$337]))]} bind 48 VV$35$340 : {VV$35$340 : GHC.Types.Bool | [(VV$35$340 = lq_anf$36$_d117)]} bind 49 VV$35$340 : {VV$35$340 : GHC.Types.Bool | [(VV$35$340 = lq_anf$36$_d117)]} bind 50 VV$35$343 : {VV$35$343 : int | [(VV$35$343 = lq_anf$36$_d116)]}@@ -260,7 +260,7 @@        14;        15]   lhs {VV$35$F8 : GHC.Types.Bool | [(VV$35$F8 = lq_anf$36$_d117)]}-  rhs {VV$35$F8 : GHC.Types.Bool | [(Prop([VV$35$F8]))]}+  rhs {VV$35$F8 : GHC.Types.Bool | [(? Prop([VV$35$F8]))]}   id 8 tag [1]   // META constraint id 8 : tests/neg/test00.hs:11:23-35
tests/neg/test00a.fq view
@@ -1,6 +1,6 @@ // This qualifier saves the day; solve constraints WITHOUT IT -qualif Zog(v:a)  { 10 <= v }+qualif Zog(v:a) : (10 <= v)  bind 0 x : {v : int | true} bind 1 y : {v : int | true}
tests/neg/test1.fq view
@@ -1,6 +1,6 @@  // This qualifier saves the day; solve constraints WITHOUT IT-qualif Zog(v:a)  { 10 <= v }+qualif Zog(v:a) : (10 <= v)  bind 0 x : {v : int | v = 9} bind 1 y : {v : int | v = 20}
tests/neg/test2.fq view
@@ -1,9 +1,9 @@  // This qualifier saves the day; solve constraints WITHOUT IT-qualif Zog(v:a) { 10 <= v }+qualif Zog(v:a): (10 <= v)  // But you may use this one-qualif Pog(v:a) { 0 <= v }+qualif Pog(v:a): (0 <= v)  bind 0 x: {v: int | v = 9 } bind 1 a: {v: int | $k1    }
tests/neg/test3.fq view
@@ -1,5 +1,5 @@ -qualif Zog(v:a, z:b)  { v = z }+qualif Zog(v:a, z:b) : (v = z)  bind 0 x : {v : int | true} bind 1 q : {v : int | true}
tests/pos/LogicCurry1.hs.fq view
@@ -1,46 +1,46 @@ fixpoint "--allowho" -qualif Fst(v : @(1), y : @(0)) { (v = (fst y))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.spec" (line 28, column 8)-qualif Snd(v : @(1), y : @(0)) { (v = (snd y))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.spec" (line 29, column 8)-qualif Auto(v##1 : int, n : int, x : int) { (v##1 = (ack n x))  } // "/Users/rjhala/research/stack/liquidhaskell/tests/pos/LogicCurry1.hs" (line 10, column 1)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { (v <=> ((len xs) > 0))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 13, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { (v <=> ((len xs) = 0))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 14, column 8)-qualif ListZ(v : [@(0)]) { ((len v) = 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 16, column 8)-qualif ListZ(v : [@(0)]) { ((len v) >= 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 17, column 8)-qualif ListZ(v : [@(0)]) { ((len v) > 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 18, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) = (len xs))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 20, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) >= (len xs))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 21, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) > (len xs))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 22, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) <= (len xs))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 23, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) < (len xs))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 24, column 8)-qualif EqLen(v : int, xs : [@(0)]) { (v = (len xs))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 26, column 8)-qualif LenEq(v : [@(0)], x : int) { (x = (len v))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 27, column 8)-qualif LenDiff(v : [@(0)], x : int) { ((len v) = (x + 1))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 28, column 8)-qualif LenDiff(v : [@(0)], x : int) { ((len v) = (x - 1))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 29, column 8)-qualif LenAcc(v : int, xs : [@(0)], n : int) { (v = ((len xs) + n))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 30, column 8)-qualif Bot(v : @(0)) { (0 = 1)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 3, column 8)-qualif Bot(v : @(0)) { (0 = 1)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 4, column 8)-qualif Bot(v : @(0)) { (0 = 1)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 5, column 8)-qualif Bot(v : bool) { (0 = 1)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 6, column 8)-qualif Bot(v : int) { (0 = 1)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 7, column 8)-qualif CmpZ(v : @(0)) { (v < 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 9, column 8)-qualif CmpZ(v : @(0)) { (v <= 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 10, column 8)-qualif CmpZ(v : @(0)) { (v > 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 11, column 8)-qualif CmpZ(v : @(0)) { (v >= 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 12, column 8)-qualif CmpZ(v : @(0)) { (v = 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 13, column 8)-qualif CmpZ(v : @(0)) { (v != 0)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 14, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v < x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 16, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v <= x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 17, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v > x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 18, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v >= x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 19, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v = x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 20, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v != x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 21, column 8)-qualif One(v : int) { (v = 1)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 28, column 8)-qualif True1(v : GHC.Types.Bool) { v  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 29, column 8)-qualif False1(v : GHC.Types.Bool) { (~ (v))  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 30, column 8)-qualif Papp(v : @(0), p : (Pred  @(0))) { (papp1 p v)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 34, column 8)-qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))) { (papp2 p v x)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 37, column 8)-qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))) { (papp3 p v x y)  } // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 39, column 8)+qualif Fst(v : @(1), y : @(0)): ((v = (fst y))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.spec" (line 28, column 8)+qualif Snd(v : @(1), y : @(0)): ((v = (snd y))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.spec" (line 29, column 8)+qualif Auto(v##1 : int, n : int, x : int): ((v##1 = (ack n x))) // "/Users/rjhala/research/stack/liquidhaskell/tests/pos/LogicCurry1.hs" (line 10, column 1)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((v <=> ((len xs) > 0))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 13, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((v <=> ((len xs) = 0))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 14, column 8)+qualif ListZ(v : [@(0)]): (((len v) = 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 16, column 8)+qualif ListZ(v : [@(0)]): (((len v) >= 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 17, column 8)+qualif ListZ(v : [@(0)]): (((len v) > 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 18, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) = (len xs))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 20, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) >= (len xs))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 21, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) > (len xs))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 22, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) <= (len xs))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 23, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) < (len xs))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 24, column 8)+qualif EqLen(v : int, xs : [@(0)]): ((v = (len xs))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 26, column 8)+qualif LenEq(v : [@(0)], x : int): ((x = (len v))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 27, column 8)+qualif LenDiff(v : [@(0)], x : int): (((len v) = (x + 1))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 28, column 8)+qualif LenDiff(v : [@(0)], x : int): (((len v) = (x - 1))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 29, column 8)+qualif LenAcc(v : int, xs : [@(0)], n : int): ((v = ((len xs) + n))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/GHC/Base.hquals" (line 30, column 8)+qualif Bot(v : @(0)): ((0 = 1)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 3, column 8)+qualif Bot(v : @(0)): ((0 = 1)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 4, column 8)+qualif Bot(v : @(0)): ((0 = 1)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 5, column 8)+qualif Bot(v : bool): ((0 = 1)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 6, column 8)+qualif Bot(v : int): ((0 = 1)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 7, column 8)+qualif CmpZ(v : @(0)): ((v < 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 9, column 8)+qualif CmpZ(v : @(0)): ((v <= 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 10, column 8)+qualif CmpZ(v : @(0)): ((v > 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 11, column 8)+qualif CmpZ(v : @(0)): ((v >= 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 12, column 8)+qualif CmpZ(v : @(0)): ((v = 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 13, column 8)+qualif CmpZ(v : @(0)): ((v != 0)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 14, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v < x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 16, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v <= x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 17, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v > x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 18, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v >= x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 19, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v = x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 20, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v != x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 21, column 8)+qualif One(v : int): ((v = 1)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 28, column 8)+qualif True1(v : GHC.Types.Bool): (v) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 29, column 8)+qualif False1(v : GHC.Types.Bool): ((~ (v))) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 30, column 8)+qualif Papp(v : @(0), p : (Pred  @(0))): ((papp1 p v)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 34, column 8)+qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))): ((papp2 p v x)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 37, column 8)+qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))): ((papp3 p v x y)) // "/Users/rjhala/research/stack/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2016-05-21/7.10.3/share/x86_64-osx-ghc-7.10.3/liquidhaskell-0.6.0.0/include/Prelude.hquals" (line 39, column 8)
tests/pos/MergeSort.fq view
@@ -1,52 +1,52 @@-qualif Fst(v : @(1), y : @(0)) { (v = (fst y))  } // "tests/todo/MergeSort.new.min.fq" (line 1, column 8)-qualif Snd(v : @(1), y : @(0)) { (v = (snd y))  } // "tests/todo/MergeSort.new.min.fq" (line 2, column 8)-qualif Auto(VV : @(0), fld##0 : @(0)) { (VV >= fld##0)  } // "tests/todo/MergeSort.new.min.fq" (line 3, column 8)-qualif Auto(VV : @(0), fld##0 : @(0)) { (VV >= fld##0)  } // "tests/todo/MergeSort.new.min.fq" (line 4, column 8)-qualif Auto(VV : [@(0)], xs : [@(0)], ys : [@(0)]) { ((len VV) = ((len xs) + (len ys)))  } // "tests/todo/MergeSort.new.min.fq" (line 5, column 8)-qualif Auto(VV : @(0), fld##0 : @(0)) { (VV >= fld##0)  } // "tests/todo/MergeSort.new.min.fq" (line 6, column 8)-qualif Auto(VV : [@(0)], xs : [@(0)]) { ((len VV) = (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 7, column 8)-qualif Auto(VV : @(0), fld##0 : @(0)) { (VV >= fld##0)  } // "tests/todo/MergeSort.new.min.fq" (line 8, column 8)-qualif Auto(v##0 : (Tuple  [@(0)]  [@(0)]), xs : [@(0)]) { (((len (fst v##0)) + (len (snd v##0))) = (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 9, column 8)-qualif Auto(v##0 : [@(0)], xs : [@(0)]) { (((len v##0) > 1) => ((len v##0) < (len xs)))  } // "tests/todo/MergeSort.new.min.fq" (line 10, column 8)-qualif Auto(v##0 : [@(0)], xs : [@(0)]) { (((len v##0) > 1) => ((len v##0) < (len xs)))  } // "tests/todo/MergeSort.new.min.fq" (line 11, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { ((Prop v) <=> ((len xs) > 0))  } // "tests/todo/MergeSort.new.min.fq" (line 12, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { ((Prop v) <=> ((len xs) = 0))  } // "tests/todo/MergeSort.new.min.fq" (line 13, column 8)-qualif ListZ(v : [@(0)]) { ((len v) = 0)  } // "tests/todo/MergeSort.new.min.fq" (line 14, column 8)-qualif ListZ(v : [@(0)]) { ((len v) >= 0)  } // "tests/todo/MergeSort.new.min.fq" (line 15, column 8)-qualif ListZ(v : [@(0)]) { ((len v) > 0)  } // "tests/todo/MergeSort.new.min.fq" (line 16, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) = (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 17, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) >= (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 18, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) > (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 19, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) <= (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 20, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { ((len v) < (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 21, column 8)-qualif EqLen(v : int, xs : [@(0)]) { (v = (len xs))  } // "tests/todo/MergeSort.new.min.fq" (line 22, column 8)-qualif LenEq(v : [@(0)], x : int) { (x = (len v))  } // "tests/todo/MergeSort.new.min.fq" (line 23, column 8)-qualif LenDiff(v : [@(0)], x : int) { ((len v) = (x + 1))  } // "tests/todo/MergeSort.new.min.fq" (line 24, column 8)-qualif LenDiff(v : [@(0)], x : int) { ((len v) = (x - 1))  } // "tests/todo/MergeSort.new.min.fq" (line 25, column 8)-qualif LenAcc(v : int, xs : [@(0)], n : int) { (v = ((len xs) + n))  } // "tests/todo/MergeSort.new.min.fq" (line 26, column 8)-qualif Bot(v : @(0)) { (0 = 1)  } // "tests/todo/MergeSort.new.min.fq" (line 27, column 8)-qualif Bot(v : @(0)) { (0 = 1)  } // "tests/todo/MergeSort.new.min.fq" (line 28, column 8)-qualif Bot(v : @(0)) { (0 = 1)  } // "tests/todo/MergeSort.new.min.fq" (line 29, column 8)-qualif Bot(v : bool) { (0 = 1)  } // "tests/todo/MergeSort.new.min.fq" (line 30, column 8)-qualif Bot(v : int) { (0 = 1)  } // "tests/todo/MergeSort.new.min.fq" (line 31, column 8)-qualif CmpZ(v : @(0)) { (v < 0)  } // "tests/todo/MergeSort.new.min.fq" (line 32, column 8)-qualif CmpZ(v : @(0)) { (v <= 0)  } // "tests/todo/MergeSort.new.min.fq" (line 33, column 8)-qualif CmpZ(v : @(0)) { (v > 0)  } // "tests/todo/MergeSort.new.min.fq" (line 34, column 8)-qualif CmpZ(v : @(0)) { (v >= 0)  } // "tests/todo/MergeSort.new.min.fq" (line 35, column 8)-qualif CmpZ(v : @(0)) { (v = 0)  } // "tests/todo/MergeSort.new.min.fq" (line 36, column 8)-qualif CmpZ(v : @(0)) { (v != 0)  } // "tests/todo/MergeSort.new.min.fq" (line 37, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v < x)  } // "tests/todo/MergeSort.new.min.fq" (line 38, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v <= x)  } // "tests/todo/MergeSort.new.min.fq" (line 39, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v > x)  } // "tests/todo/MergeSort.new.min.fq" (line 40, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v >= x)  } // "tests/todo/MergeSort.new.min.fq" (line 41, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v = x)  } // "tests/todo/MergeSort.new.min.fq" (line 42, column 8)-qualif Cmp(v : @(0), x : @(0)) { (v != x)  } // "tests/todo/MergeSort.new.min.fq" (line 43, column 8)-qualif One(v : int) { (v = 1)  } // "tests/todo/MergeSort.new.min.fq" (line 44, column 8)-qualif True1(v : GHC.Types.Bool) { (Prop v)  } // "tests/todo/MergeSort.new.min.fq" (line 45, column 8)-qualif False1(v : GHC.Types.Bool) { (~ ((Prop v)))  } // "tests/todo/MergeSort.new.min.fq" (line 46, column 8)-qualif Papp(v : @(0), p : (Pred  @(0))) { (papp1 p v)  } // "tests/todo/MergeSort.new.min.fq" (line 47, column 8)-qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))) { (papp2 p v x)  } // "tests/todo/MergeSort.new.min.fq" (line 48, column 8)-qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))) { (papp3 p v x y)  } // "tests/todo/MergeSort.new.min.fq" (line 49, column 8)+qualif Fst(v : @(1), y : @(0)): ((v = (fst y))) // "tests/todo/MergeSort.new.min.fq" (line 1, column 8)+qualif Snd(v : @(1), y : @(0)): ((v = (snd y))) // "tests/todo/MergeSort.new.min.fq" (line 2, column 8)+qualif Auto(VV : @(0), fld##0 : @(0)): ((VV >= fld##0)) // "tests/todo/MergeSort.new.min.fq" (line 3, column 8)+qualif Auto(VV : @(0), fld##0 : @(0)): ((VV >= fld##0)) // "tests/todo/MergeSort.new.min.fq" (line 4, column 8)+qualif Auto(VV : [@(0)], xs : [@(0)], ys : [@(0)]): (((len VV) = ((len xs) + (len ys)))) // "tests/todo/MergeSort.new.min.fq" (line 5, column 8)+qualif Auto(VV : @(0), fld##0 : @(0)): ((VV >= fld##0)) // "tests/todo/MergeSort.new.min.fq" (line 6, column 8)+qualif Auto(VV : [@(0)], xs : [@(0)]): (((len VV) = (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 7, column 8)+qualif Auto(VV : @(0), fld##0 : @(0)): ((VV >= fld##0)) // "tests/todo/MergeSort.new.min.fq" (line 8, column 8)+qualif Auto(v##0 : (Tuple  [@(0)]  [@(0)]), xs : [@(0)]): ((((len (fst v##0)) + (len (snd v##0))) = (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 9, column 8)+qualif Auto(v##0 : [@(0)], xs : [@(0)]): ((((len v##0) > 1) => ((len v##0) < (len xs)))) // "tests/todo/MergeSort.new.min.fq" (line 10, column 8)+qualif Auto(v##0 : [@(0)], xs : [@(0)]): ((((len v##0) > 1) => ((len v##0) < (len xs)))) // "tests/todo/MergeSort.new.min.fq" (line 11, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): (((Prop v) <=> ((len xs) > 0))) // "tests/todo/MergeSort.new.min.fq" (line 12, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): (((Prop v) <=> ((len xs) = 0))) // "tests/todo/MergeSort.new.min.fq" (line 13, column 8)+qualif ListZ(v : [@(0)]): (((len v) = 0)) // "tests/todo/MergeSort.new.min.fq" (line 14, column 8)+qualif ListZ(v : [@(0)]): (((len v) >= 0)) // "tests/todo/MergeSort.new.min.fq" (line 15, column 8)+qualif ListZ(v : [@(0)]): (((len v) > 0)) // "tests/todo/MergeSort.new.min.fq" (line 16, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) = (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 17, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) >= (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 18, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) > (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 19, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) <= (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 20, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (((len v) < (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 21, column 8)+qualif EqLen(v : int, xs : [@(0)]): ((v = (len xs))) // "tests/todo/MergeSort.new.min.fq" (line 22, column 8)+qualif LenEq(v : [@(0)], x : int): ((x = (len v))) // "tests/todo/MergeSort.new.min.fq" (line 23, column 8)+qualif LenDiff(v : [@(0)], x : int): (((len v) = (x + 1))) // "tests/todo/MergeSort.new.min.fq" (line 24, column 8)+qualif LenDiff(v : [@(0)], x : int): (((len v) = (x - 1))) // "tests/todo/MergeSort.new.min.fq" (line 25, column 8)+qualif LenAcc(v : int, xs : [@(0)], n : int): ((v = ((len xs) + n))) // "tests/todo/MergeSort.new.min.fq" (line 26, column 8)+qualif Bot(v : @(0)): ((0 = 1)) // "tests/todo/MergeSort.new.min.fq" (line 27, column 8)+qualif Bot(v : @(0)): ((0 = 1)) // "tests/todo/MergeSort.new.min.fq" (line 28, column 8)+qualif Bot(v : @(0)): ((0 = 1)) // "tests/todo/MergeSort.new.min.fq" (line 29, column 8)+qualif Bot(v : bool): ((0 = 1)) // "tests/todo/MergeSort.new.min.fq" (line 30, column 8)+qualif Bot(v : int): ((0 = 1)) // "tests/todo/MergeSort.new.min.fq" (line 31, column 8)+qualif CmpZ(v : @(0)): ((v < 0)) // "tests/todo/MergeSort.new.min.fq" (line 32, column 8)+qualif CmpZ(v : @(0)): ((v <= 0)) // "tests/todo/MergeSort.new.min.fq" (line 33, column 8)+qualif CmpZ(v : @(0)): ((v > 0)) // "tests/todo/MergeSort.new.min.fq" (line 34, column 8)+qualif CmpZ(v : @(0)): ((v >= 0)) // "tests/todo/MergeSort.new.min.fq" (line 35, column 8)+qualif CmpZ(v : @(0)): ((v = 0)) // "tests/todo/MergeSort.new.min.fq" (line 36, column 8)+qualif CmpZ(v : @(0)): ((v != 0)) // "tests/todo/MergeSort.new.min.fq" (line 37, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v < x)) // "tests/todo/MergeSort.new.min.fq" (line 38, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v <= x)) // "tests/todo/MergeSort.new.min.fq" (line 39, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v > x)) // "tests/todo/MergeSort.new.min.fq" (line 40, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v >= x)) // "tests/todo/MergeSort.new.min.fq" (line 41, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v = x)) // "tests/todo/MergeSort.new.min.fq" (line 42, column 8)+qualif Cmp(v : @(0), x : @(0)): ((v != x)) // "tests/todo/MergeSort.new.min.fq" (line 43, column 8)+qualif One(v : int): ((v = 1)) // "tests/todo/MergeSort.new.min.fq" (line 44, column 8)+qualif True1(v : GHC.Types.Bool): ((Prop v)) // "tests/todo/MergeSort.new.min.fq" (line 45, column 8)+qualif False1(v : GHC.Types.Bool): ((~ ((Prop v)))) // "tests/todo/MergeSort.new.min.fq" (line 46, column 8)+qualif Papp(v : @(0), p : (Pred  @(0))): ((papp1 p v)) // "tests/todo/MergeSort.new.min.fq" (line 47, column 8)+qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))): ((papp2 p v x)) // "tests/todo/MergeSort.new.min.fq" (line 48, column 8)+qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))): ((papp3 p v x y)) // "tests/todo/MergeSort.new.min.fq" (line 49, column 8)   cut $k_##795
tests/pos/T416.fq view
@@ -7,7 +7,7 @@ ]  define compose (lq1:func(0,[b;c]), lq2:func(0,[a;b]), lq3:a) : c = { lq1 (lq2 lq3) }-define first (lq1:func(0,[a;c]),  lq2:(Pair a b)) : Pair c b = {+define first (lq1:func(0,[a;c]),  lq2:(Pair a b)) : Pair a c = {   Pair (lq1 (pfst lq2)) (psnd lq2) } define plus1 (x:int) : int = { x + 1 }@@ -22,7 +22,7 @@                                  @(1)])) constant first : (func(3 , [func(0 , [@(1); @(2)]);                                            (Pair @(1) @(0));-                                           (Pair @(2) @(0))]))+                                           (Pair @(2) @(0))]))                                   bind 0 g : {VV : func(0 , [b; c]) | []} bind 1 f : {VV : func(0 , [a; b]) | []}
− tests/pos/T753A.fq 
@@ -1,45 +0,0 @@-// Config {srcFile = "tests/pos/T2535.hs", cores = Nothing, minPartSize = 500, maxPartSize = 700, solver = z3, linear = False, stringTheory = False, defunction = False, allowHO = True, allowHOqs = False, eliminate = some, scrape = no, elimBound = Nothing, smtTimeout = Nothing, elimStats = False, solverStats = False, metadata = False, stats = False, parts = False, save = True, minimize = False, minimizeQs = False, minimizeKs = False, minimalSol = False, etaElim = False, gradual = False, ginteractive = False, autoKuts = False, nonLinCuts = False, noslice = False, rewriteAxioms = False, pleWithUndecidedGuards = False, etabeta = False, localRewrites = False, interpreter = False, oldPLE = False, noIncrPle = False, noEnvironmentReduction = True, inlineANFBindings = False, checkCstr = [], extensionality = False, rwTerminationCheck = False, stdin = False, json = False, noLazyPLE = False, fuel = Nothing, restOrdering = "rpo", noSmtHorn = False}--data AB 2 = [-       | B {selectB : int}-       | A {selectA : int}-     ]-data T 1 = [-       | T {selectT1 : @(0)}-     ]--match selectA A lq_tmp$x##423   { lq_tmp$x##423 }-match selectB B lq_tmp$x##502   { lq_tmp$x##502 }-match check A lq_tmp$x##423   { true }-match check B lq_tmp$x##502   { false }-match isA A lq_tmp$x##423   { true }-match isA B lq_tmp$x##502   { false }--constant A : (func(2 , [int; (AB @(0) @(1))]))-constant selectA : (func(2 , [(AB @(0) @(1)); int]))-constant B : (func(2 , [int; (AB @(0) @(1))]))-constant selectB : (func(2 , [(AB @(0) @(1)); int]))-constant T : (func(1 , [@(0); (T @(0))]))-distinct A : (func(2 , [int; (AB @(0) @(1))]))-distinct B : (func(2 , [int; (AB @(0) @(1))]))---bind 1 A : {VV : func(2 , [int; (AB @(0) @(1))]) | []}-bind 2 B : {VV : func(2 , [int; (AB @(0) @(1))]) | []}-bind 3 T : {VV : func(1 , [@(0); (T @(0))]) | []}-bind 4 check : {VV : func(2 , [(AB @(0) @(1)); bool]) | []}-bind 5 x : {v : (AB int (T aFD)) | [(check v)]}--constraint:-  env [1; 2; 3; 4; 5]-  lhs {VV : (AB int (T aFD)) | [(VV = (if (is$A VV) then (A (selectA VV)) else (B (selectB VV))))]}-  rhs {VV : (AB int (T aFD)) | [( 3 = (1 + 2) )]}-  id 24 tag [4]-  // META constraint id 24 : tests/pos/T2535.hs:11:1-9---// unless the sort of application is propagated in both the function and the argument -// as fixed in PR: https://github.com/ucsd-progsys/liquid-fixpoint/pull/753-// the above query crashes with -// Crash!: :1:1-1:1: Error-//   crash: SMTLIB2 respSat = Error "line 3 column 13267: Sorts (AB Int (T Int)) and (AB Int Int) are incompatible"
tests/pos/adt_qual.fq view
@@ -1,6 +1,6 @@ -qualif Eq(v:@(0), x:@(0)) { v = x }-qualif Leq(v:@(0), x:@(0)) { v <= x }+qualif Eq(v:@(0), x:@(0)): (v = x)+qualif Leq(v:@(0), x:@(0)): (v <= x)  data Zob 0 = [   | boo { choo : int }
tests/pos/bad-subst00.fq view
@@ -1,5 +1,5 @@-qualif Zog(v:a)  { 10 <= v }-qualif Bog(v:a, x:a)  { x <= v }+qualif Zog(v:a) : (10 <= v)+qualif Bog(v:a, x:a) : (x <= v)  bind 0 a : {v: int | $k0[zogbert := pikachu] }
tests/pos/bad-subst01.fq view
@@ -1,8 +1,8 @@ // fixpoint "--eliminate=some"  -qualif Zog(v:a)  { 10 <= v }-qualif Bog(v:a, x:a)  { x <= v }+qualif Zog(v:a) : (10 <= v)+qualif Bog(v:a, x:a) : (x <= v)  bind 0 a : {v: int | $k0 }
tests/pos/bad-subst02.fq view
@@ -1,6 +1,6 @@ fixpoint "--eliminate=none" -qualif Eq(v:a, x:a) { v = x }+qualif Eq(v:a, x:a): (v = x)  bind 0 x0 : {v: a0 | true } bind 1 x1 : {v: a1 | true }
− tests/pos/bags.fq 
@@ -1,48 +0,0 @@--bind 1 b1 : {v : Bag_t Int | v = Bag_empty 0 }-bind 2 b2 : {v : Bag_t Int | v = (Bag_union (Bag_sng 10 1) (Bag_sng 20 1)) }-bind 3 b3 : {v : Bag_t Int | v = (Bag_union (Bag_sng 20 1) (Bag_sng 10 1)) }-bind 4 b4 : {v : Bag_t Int | v = (Bag_sng 10 1) }-bind 5 b5 : {v : Bag_t Int | v = (Bag_sng 20 1) }--constraint:-  env [ 1 ]-  lhs {v : int | v = Bag_count 100 b1 }-  rhs {v : int | v = 0 }-  id 1 tag []--constraint:-  env [ 2 ]-  lhs {v : int | v = Bag_count 100 b2 }-  rhs {v : int | v = 0 }-  id 2 tag []--constraint:-  env [ 2 ]-  lhs {v : int | v = Bag_count 10 b2 }-  rhs {v : int | v = 1 }-  id 3 tag []--constraint:-  env [ 2; 3 ]-  lhs {v : int | true }-  rhs {v : int | b2 = b3 }-  id 4 tag []--constraint:-  env [ 2; 4; 5 ]-  lhs {v : int | true }-  rhs {v : int | b2 = Bag_union b4 b5 }-  id 5 tag []--constraint:-  env [ 2; 4 ]-  lhs {v : bool | v = Bag_sub b4 b2 }-  rhs {v : bool | v = true }-  id 6 tag []--constraint:-  env [ 3; 5 ]-  lhs {v : bool | v = Bag_sub b3 b5 }-  rhs {v : bool | v = false }-  id 7 tag []
− tests/pos/bags02.fq 
@@ -1,39 +0,0 @@-bind 1 b1 : {v : Bag_t Int | v = Bag_empty 0 }-bind 2 b2 : {v : Bag_t Int | v = (Bag_union (Bag_union (Bag_sng 10 1) (Bag_sng 20 2)) (Bag_sng 30 3)) }-bind 3 b3 : {v : Bag_t Int | v = (Bag_union (Bag_union (Bag_sng 10 1) (Bag_sng 20 1)) (Bag_sng 30 1)) }--constraint:-  env [ 2; 3 ]-  lhs {v : Bag_t Int | v = Bag_union_max b2 b3}-  rhs {v : Bag_t Int | v = b2 }-  id 1 tag []--constraint:-  env [ 1; 2 ]-  lhs {v : Bag_t Int | v = Bag_union_max b1 b2}-  rhs {v : Bag_t Int | v = b2 }-  id 2 tag []--constraint:-  env [ 1; 3 ]-  lhs {v : Bag_t Int | v = Bag_union_max b1 b3}-  rhs {v : Bag_t Int | v = b3 }-  id 3 tag []--constraint:-  env [ 2; 3 ]-  lhs {v : Bag_t Int | v = Bag_inter_min b2 b3}-  rhs {v : Bag_t Int | v = b3 }-  id 4 tag []--constraint:-  env [ 1; 2 ]-  lhs {v : Bag_t Int | v = Bag_inter_min b1 b2}-  rhs {v : Bag_t Int | v = b1 }-  id 5 tag []--constraint:-  env [ 1; 3 ]-  lhs {v : Bag_t Int | v = Bag_inter_min b1 b3}-  rhs {v : Bag_t Int | v = b1 }-  id 6 tag []
− tests/pos/bitvec-ii.fq 
@@ -1,65 +0,0 @@-// This file showcases bitvector functions that in smtlib2 are-// indexed identifiers. This means that instead of writing-// (zero_extend 2 bv) to extend a bitvector by 2 bits, we-// write ((_ zero_extend 2) bv).--// You can see the '_' as kind of applying type level arguments.-// In the case of 'zero_extend', it determines the size of the-// output bitvector. --// To emulate this in liquid fixpoint, we want the output to -// match exactly the format of indexed identifiers of smtlib2. -// This comes down to defining our own '_' and parenthesizing -// the expression in LF exactly as we would in the smt format.--// The last trick here, is that we cannot apply a parenthesized-// expression to an expression. For this we have defined the -// additional expression 'app', which simply applies its operands.-// 'app' is elaborated to the empty string to the SMT solver, such-// that (app (_ zero_extend 2) bv) becomes ( (_ zero_extend 2) bv).--bind 0 x : {v : (BitVec Size4) | v = (lit "#b1000" (BitVec Size4))}-bind 1 y : {v : (BitVec Size4) | v = (app (_ rotate_right 7) x)}-bind 2 z : {v : (BitVec Size4) | v = (lit "#b0001" (BitVec Size4))}--constraint:-  env [0;1;2]-  lhs {v : (BitVec Size4) | [ v = y ] }-  rhs {v : (BitVec Size4) | [ v = z ] }-  id 0 tag []--bind 3 y : {v : (BitVec Size6) | v = (app (_ zero_extend 2) x)}-bind 4 z : {v : (BitVec Size6) | v = (lit "#b001000" (BitVec Size6))}--constraint:-  env [0;3;4]-  lhs {v : (BitVec Size6) | [ v = y ] }-  rhs {v : (BitVec Size6) | [ v = z ] }-  id 1 tag []--bind 5 y : {v : (BitVec Size6) | v = (app (_ sign_extend 2) x)}-bind 6 z : {v : (BitVec Size6) | v = (lit "#b111000" (BitVec Size6))}--constraint:-  env [0;5;6]-  lhs {v : (BitVec Size6) | [ v = y ] }-  rhs {v : (BitVec Size6) | [ v = z ] }-  id 2 tag []--bind 7 y : {v : (BitVec Size8) | v = (app (_ repeat 2) x)}-bind 8 z : {v : (BitVec Size8) | v = (lit "#b10001000" (BitVec Size8))}--constraint:-  env [0;7;8]-  lhs {v : (BitVec Size8) | [ v = y ] }-  rhs {v : (BitVec Size8) | [ v = z ] }-  id 3 tag []--bind 9  y : {v : (BitVec Size2) | v = (app (_ extract 3 2) x)}-bind 10 z : {v : (BitVec Size2) | v = (lit "#b10" (BitVec Size2))}--constraint:-  env [0;9;10]-  lhs {v : (BitVec Size2) | [ v = y ] }-  rhs {v : (BitVec Size2) | [ v = z ] }-  id 4 tag []
− tests/pos/bitvec.fq 
@@ -1,89 +0,0 @@-bind 0 x : {v : (BitVec Size32) | [ v = (lit "#x0000000f" (BitVec Size32))]}-bind 1 y : {v : (BitVec Size32) | [ v = (lit "#x000000f0" (BitVec Size32))]}-bind 2 z : {v : (BitVec Size32) | [ v = (lit "#x000000ff" (BitVec Size32))]}--constraint:-  env [0;1;2]-  lhs {v : (BitVec Size32) | [ v = bvor x y ] }-  rhs {v : (BitVec Size32) | [ v = z ] }-  id 0 tag []--bind 4 x : {v : (BitVec Size60) | [ v = (lit "#x00000000000000f" (BitVec Size60))]}-bind 5 y : {v : (BitVec Size60) | [ v = (lit "#x0000000000000f0" (BitVec Size60))]}-bind 6 z : {v : (BitVec Size60) | [ v = (lit "#x000000000000000" (BitVec Size60))]}--constraint:-  env [4;5;6]-  lhs {v : (BitVec Size60) | [ v = bvand x y ] }-  rhs {v : (BitVec Size60) | [ v = z ] }-  id 1 tag []--bind 7 x : {v : (BitVec Size4) | [ v = (lit "#x5" (BitVec Size4))]}-bind 8 y : {v : (BitVec Size4) | [ v = (lit "#xb" (BitVec Size4))]}-bind 9 z : {v : (BitVec Size4) | [ v = (lit "#x1" (BitVec Size4))]}--constraint:-  env [7;8;9]-  lhs {v : (BitVec Size4) | [ v = bvxnor x y ] }-  rhs {v : (BitVec Size4) | [ v = z ] }-  id 2 tag []--bind 10 x : {v : (BitVec Size4) | [ v = (lit "#x4" (BitVec Size4))]}-bind 11 y : {v : (BitVec Size4) | [ v = (lit "#xb" (BitVec Size4))]}--constraint:-  env [10;11]-  lhs {v : (BitVec Size4) | [ v = bvnot x ] }-  rhs {v : (BitVec Size4) | [ v = y; y != bvneg x] }-  id 3 tag []--bind 12 x : {v : (BitVec Size4) | [ v = (lit "#x4" (BitVec Size4))]}-bind 13 y : {v : (BitVec Size4) | [ v = (lit "#xc" (BitVec Size4))]}--constraint:-  env [12;13]-  lhs {v : (BitVec Size4) | [ v = bvneg x ] }-  rhs {v : (BitVec Size4) | [ v = y; y != bvnot x ] }-  id 4 tag []--bind 14 x : {v : (BitVec Size4) | true }-bind 15 y : {v : (BitVec Size4) | true }--constraint:-  env [14;15]-  lhs {v : (BitVec Size4) | [ v = bvand x y ] }-  rhs {v : (BitVec Size4) | [ v = bvand y x ] }-  id 5 tag []--bind 16 x : {v : (BitVec Size4) | [ v = (lit "#b1010" (BitVec Size4))]}-bind 17 y : {v : (BitVec Size4) | [ v = (lit "#x1" (BitVec Size4))]}-bind 18 z : {v : (BitVec Size4) | [ v = (lit "#b0101" (BitVec Size4))]}--constraint:-  env [16;17;18]-  lhs {v : (BitVec Size4) | [ v = bvlshr x y ] }-  rhs {v : (BitVec Size4) | [ v = z ] }-  id 6 tag []--constraint:-  env [16;18]-  lhs {v : (BitVec Size4) | [ v = z ] }-  rhs {v : (BitVec Size4) | [ v = z; bvult z x ] }-  id 7 tag []--bind 19 z : {v : (BitVec Size8) | [ v = (lit "#b10100001" (BitVec Size8))]}--constraint:-  env [16;17;19]-  lhs {v : (BitVec Size8) | [ v = concat x y ] }-  rhs {v : (BitVec Size8) | [ v = z ] }-  id 8 tag []--constraint:-  env [19]-  lhs {v : (BitVec Size1) | [ v = bvcomp z z ] }-  rhs {v : (BitVec Size1) | [ v = (lit "#b1" (BitVec Size1)) ] }-  id 9 tag []---
tests/pos/bool00.fq view
@@ -1,5 +1,5 @@-qualif Zog(v:a)  { 10 <= v }-qualif Bog(v:a, x:a)  { x <= v }+qualif Zog(v:a) : (10 <= v)+qualif Bog(v:a, x:a) : (x <= v)  bind 0 a  : {v: int  | $k0} bind 1 tt : {v: bool | v}
tests/pos/bool03.fq view
@@ -1,7 +1,7 @@  // qualif LE(v:a, x:a): (bool_to_int x <= bool_to_int v) -qualif LE(v:a, x:a) { x <= v }+qualif LE(v:a, x:a): (x <= v)  constant lit$36$not$45$the$45$hippopotamus : (Str) constant lit#cat : (Str)
+ tests/pos/bool04.fq view
@@ -0,0 +1,20 @@+fixpoint "--eliminate=some"++bind 1 bx : {v: int  | true }+bind 2 by : {v: bool | true }++constraint:+  env [ 2 ]+  lhs {v : int | true }+  rhs {v : int | $k1[bx := by] }+  id 1 tag []++constraint:+  env [ 1 ]+  lhs {v : int | $k1    }+  rhs {v : int | v <= v + 1 }+  id 2 tag []++wf:+  env [1]+  reft {v : int | $k1 }
+ tests/pos/ebind-00.fq view
@@ -0,0 +1,16 @@+fixpoint "--eliminate=all"++// bind  0 x1 : {v: int | v = 10 }+ebind 0 x1 : { int }++constraint:+  env [0]+  lhs {v1 : int | v1 = 10}+  rhs {v1 : int | v1 = x1}+  id 1 tag []++constraint:+  env [0]+  lhs {v2 : int | v2 = x1 + 1 }+  rhs {v2 : int | v2 = 11     }+  id 2 tag []
+ tests/pos/ebind-01.fq view
@@ -0,0 +1,17 @@+fixpoint "--eliminate=all"++bind  1 m  : {v: int | true }+ebind 2 x1 : { int }+// bind  2 x1 : {v: int | v = m + 1 }++constraint:+  env [1; 2]+  lhs {v : int | v = m + 1 }+  rhs {v : int | v = x1    }+  id 1 tag []++constraint:+  env [1; 2]+  lhs {v : int | v = x1 + 1}+  rhs {v : int | v = 2 + m }+  id 2 tag []
+ tests/pos/ebind-02.fq view
@@ -0,0 +1,28 @@+fixpoint "--eliminate=all"++bind  0 m  : {v: int | true }+bind  1 z  : {v: int | v = m - 1 }+ebind 2 x1 : { int }+// bind  2 x1 : {v: int | v = m + 1 }++constraint:+  env [0; 1]+  lhs {v : int | v = z + 2 }+  rhs {v : int | $k         }+  id 1 tag []++constraint:+  env [0; 2]+  lhs {v : int | $k      }+  rhs {v : int | v = x1 }+  id 2 tag []++constraint:+  env [0; 2]+  lhs {v : int | v = x1 + 1 }+  rhs {v : int | v = m  + 2 }+  id 3 tag []++wf: +  env [0]+  reft {v:int | [$k] }
+ tests/pos/ebind-03.fq view
@@ -0,0 +1,45 @@+fixpoint "--eliminate=all"++ebind 1 x1 : { int }+ebind 2 x2 : { int }+++constraint:+  env [1]+  lhs {v : int | v = 1  }+  rhs {v : int | v = x1 }+  id 1 tag []++constraint:+  env [1]+  lhs {v : int | v = x1 + 1 }+  rhs {v : int | $ka        }+  id 2 tag []++constraint:+  env [2]+  lhs {v : int | $ka    }+  rhs {v : int | v = x2 }+  id 3 tag []++constraint:+  env [2]+  lhs {v : int | v = x2 + 1}+  rhs {v : int | $kb       }+  id 4 tag []++constraint:+  env []+  lhs {v : int | $kb   }+  rhs {v : int | v = 3 } +  id 5 tag []+++wf: +  env []+  reft {v:int | [$ka] }++wf: +  env []+  reft {v:int | [$kb] }+
+ tests/pos/ebind-03a.fq view
@@ -0,0 +1,55 @@+fixpoint "--eliminate=all"++ebind 1 x1 : { int }+ebind 2 x2 : { int }++constraint:+  env []+  lhs {v : int | v = 1 }+  rhs {v : int | $kone }+  id 10 tag []++constraint:+  env [1]+  lhs {v : int | $kone  }+  rhs {v : int | v = x1 }+  id 1 tag []++constraint:+  env [1]+  lhs {v : int | v = x1 + 1 }+  rhs {v : int | $ka        }+  id 2 tag []++constraint:+  env [2]+  lhs {v : int | $ka    }+  rhs {v : int | v = x2 }+  id 3 tag []++constraint:+  env [2]+  lhs {v : int | v = x2 + 1}+  rhs {v : int | $kb       }+  id 4 tag []++constraint:+  env []+  lhs {v : int | $kb   }+  rhs {v : int | v = 3 } +  id 5 tag []+++wf: +  env []+  reft {v:int | [$ka] }++wf: +  env []+  reft {v:int | [$kb] }++wf: +  env []+  reft {v:int | [$kone] }++
+ tests/pos/ebind-04.fq view
@@ -0,0 +1,35 @@+fixpoint "--eliminate=all"++ebind 1 x : { int }++constraint:+  env [1]+  lhs {v : int | $k1   }+  rhs {v : int | v = x }+  id 1 tag []++constraint:+  env [1]+  lhs {v : int | v = x + 1 }+  rhs {v : int | $k2       }+  id 2 tag []++constraint:+  env []+  lhs {v : int | v = 3 }+  rhs {v : int | $k1   }+  id 3 tag []++constraint:+  env []+  lhs {v : int | $k2   }+  rhs {v : int | v = 4 }+  id 4 tag []++wf: +  env []+  reft {v:int | [$k1] }++wf: +  env []+  reft {v:int | [$k2] }
+ tests/pos/ebind-05.fq view
@@ -0,0 +1,31 @@+fixpoint "--eliminate=some"++// This file is SAFE with --eliminate=none+// but both qualifiers are needed++bind  16 m    : {VV##131 : int | true }+ebind 19 n    : { int }++constraint:+  env [16; 19]+  lhs {VV##F##4 : int | $k_##137[VV##136:=VV##F##4] }+  rhs {VV##F##4 : int | VV##F##4 = n                }+  id 4 tag []++constraint:+  env [16]+  lhs {VV##F##5 : int | VV##F##5 = m + 1          }+  rhs {VV##F##5 : int | $k_##137[VV##136:=VV##F##5] }+  id 5 tag []++// Constraint 3 is only needed to prevent the *sharing* optimization++constraint:+  env [16; 19]+  lhs {VV##F##3 : int | false     }+  rhs {VV##F##3 : int | $k_##137[VV##136:=VV##F##3] }+  id 3 tag []++wf:+  env [16]+  reft {VV##136 : int   | [$k_##137]}
+ tests/pos/ebind-06.fq view
@@ -0,0 +1,27 @@+fixpoint "--eliminate=some"++bind  16 m    : {VV##131 : int | true }+ebind 19 n    : { int }++constraint:+  env [16; 19]+  lhs {VV##F##3 : int | VV##F##3 = n                     }+  rhs {VV##F##3 : int | VV##F##3 = m + 1 && VV##F##3 = 3 }+  id 3 tag []++constraint:+  env [16; 19]+  lhs {VV##F##4 : int | VV##F##4 = 3 }+  rhs {VV##F##4 : int | VV##F##4 = n }+  id 4 tag []++constraint:+  env [16; 19]+  lhs {VV##F##5 : int | VV##F##5 = m + 1 }+  rhs {VV##F##5 : int | VV##F##5 = n     }+  id 5 tag []+++wf:+  env [16]+  reft {VV##136 : int   | [$k_##137]}
tests/pos/elim00.fq view
@@ -1,8 +1,8 @@ fixpoint "--defunct"  // trick is to do it without these-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)+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;
− tests/pos/eta_cons.fq 
@@ -1,24 +0,0 @@-fixpoint "--rewrite"-fixpoint "--allowho"-fixpoint "--etabeta"--constant f : (func(0 , [int; int; int]))-define f (x : int, y: int) : int = {(x + y)}--constant g : (func(0 , [int; int; int]))-define g (a : int, b: int) : int = {(b + a)}---data Ty 0 = [-    | Cons {mkCons : func(0 , [int; int; int])}-]--constant Cons : (func(0 , [func(0 , [int; int; int]); Ty]))--expand [1 : True; 2 : True]--constraint:-  env []-  lhs {VV1 : Tuple | true }-  rhs {VV2 : Tuple | (Cons f = Cons g) }-  id 2 tag []
− tests/pos/ext_double_unfold.fq 
@@ -1,19 +0,0 @@-fixpoint "--rewrite"-fixpoint "--extensionality"--constant f : (func(0 , [int; int]))-define f (x : int) : int = {(13)}--constant g : (func(0, [int; int; int]))-define g (a : int,  b : int) : int = {(f b)}--constant k : (func(0, [int; int; int]))-define k (u : int,  m : int) : int = {(13)}--expand [1 : True; 2 : True]--constraint:-  env []-  lhs {VV1 : Tuple | true }-  rhs {VV2 : Tuple | (g = k) }-  id 1 tag []
− tests/pos/ext_lam.fq 
@@ -1,14 +0,0 @@-fixpoint "--rewrite"-fixpoint "--extensionality"-fixpoint "--allowho"--constant f : (func(0 , [int; int]))-define f (x : int) : int = {(13)}--expand [1 : True]--constraint:-  env []-  lhs {VV1 : Tuple | true }-  rhs {VV2 : Tuple | (f = \y : int -> 13) }-  id 1 tag []
− tests/pos/ext_lam_multi.fq 
@@ -1,14 +0,0 @@-fixpoint "--rewrite"-fixpoint "--extensionality"-fixpoint "--allowho"--constant f : (func(0 , [int; int; int]))-define f (x : int, y : int) : int = {(13)}--expand [1 : True]--constraint:-  env []-  lhs {VV1 : Tuple | true }-  rhs {VV2 : Tuple | (f = \y : int -> \k : int -> 13) }-  id 1 tag []
− tests/pos/frac.fq 
@@ -1,18 +0,0 @@-bind 0 alpha : {v : frac | true}-bind 1 x : {VV : alpha | []}-bind 2 y : {VV : alpha | [(VV != 0.0)]}----constraint:-  env [0]-  lhs {v : alpha | (v = 10.0)}-  rhs {v : alpha | (v < 11.0)}-  id 1 tag []---constraint:-  env [0;1;2]-  lhs {v : int | []}-  rhs {v : int | [(((x / y) * y) = x)]}-  id 2 tag []
tests/pos/func00.fq view
@@ -2,7 +2,7 @@ bind 0 f : {v: func(0, [int; int]) | []}  constraint:-  env [ 0 ]+  env [ ]   lhs {v : int | [f = f]}   rhs {v : int | [0 < 7]}   id 1 tag []
tests/pos/gfp00.fq view
@@ -1,7 +1,7 @@-qualif Pos(v:int)   { 0 <= v }-qualif Neg(v:int)   { v <= 0 }-qualif NeqZ(v:int)  { 0 != v }-qualif False(v:int)  { 66 = 77 }+qualif Pos(v:int)  : (0 <= v)+qualif Neg(v:int)  : (v <= 0)+qualif NeqZ(v:int) : (0 != v)+qualif False(v:int) : (66 = 77)  constraint:   env []
tests/pos/hex.ts.fq view
@@ -1,23 +1,23 @@-qualif Bot(v : a) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Bot(v : obj) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Bot(v : Boolean) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Bot(v : int) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif CmpZ(v : int) { v < 0  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif CmpZ(v : int) { v <= 0  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif CmpZ(v : int) { v > 0  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif CmpZ(v : int) { v >= 0  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif CmpZ(v : int) { v = 0  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif CmpZ(v : int) { v != 0  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Cmp(v : int, x : int) { v < x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Cmp(v : int, x : int) { v <= x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Cmp(v : int, x : int) { v > x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Cmp(v : int, x : int) { v >= x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Cmp(v : a, x : a) { v ~~ x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Cmp(v : a, x : a) { v != x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif True1(v : Boolean) { Prop([v])  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif False1(v : Boolean) { ~ ((Prop([v])))  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Tag(v : a, x : Str) { ttag([v]) = x  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)-qualif Len(v : b, w : a) { v < len([w])  } // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Bot(v : a): (0 = 1) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Bot(v : obj): (0 = 1) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Bot(v : Boolean): (0 = 1) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Bot(v : int): (0 = 1) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif CmpZ(v : int): (v < 0) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif CmpZ(v : int): (v <= 0) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif CmpZ(v : int): (v > 0) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif CmpZ(v : int): (v >= 0) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif CmpZ(v : int): (v = 0) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif CmpZ(v : int): (v != 0) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Cmp(v : int, x : int): (v < x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Cmp(v : int, x : int): (v <= x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Cmp(v : int, x : int): (v > x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Cmp(v : int, x : int): (v >= x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Cmp(v : a, x : a): (v ~~ x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Cmp(v : a, x : a): (v != x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif True1(v : Boolean): (? Prop([v])) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif False1(v : Boolean): (~ ((? Prop([v])))) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Tag(v : a, x : Str): (ttag([v]) = x) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)+qualif Len(v : b, w : a): (v < len([w])) // "/Users/rjhala/research/stack/liquid/refscript/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/refscript-0.1.0.0/include/prelude.ts" (line 1, column 1)   @@ -74,139 +74,139 @@   bind 0 undefined : {v : Undefined | [(ttag([v]) = lit$36$undefined);-                                     (~ ((Prop([v]))))]}-bind 1 Object : {VV$35$285 : Object | [(Prop([VV$35$285]));+                                     (~ ((? Prop([v]))))]}+bind 1 Object : {VV$35$285 : Object | [(? Prop([VV$35$285]));                                        (ttag([VV$35$285]) = lit$36$object)]}-bind 2 Object.prototype : {VV : (Object  Immutable) | [(extends_interface([VV;+bind 2 Object.prototype : {VV : (Object  Immutable) | [(? extends_interface([VV;                                                                              lit$36$Object]));-                                                       (Prop([VV]));+                                                       (? Prop([VV]));                                                        (ttag([VV]) = lit$36$object);                                                        (VV ~~ offset([Object; lit$36$prototype]))]} bind 3 NaN : {v : int | [(ttag([v]) = lit$36$number);-                         ((Prop([v])) <=> (v != 0));+                         ((? Prop([v])) <=> (v != 0));                          (v = numeric_nan)]}-bind 4 Number : {VV$35$325 : Object | [(Prop([VV$35$325]));+bind 4 Number : {VV$35$325 : Object | [(? Prop([VV$35$325]));                                        (ttag([VV$35$325]) = lit$36$object)]} bind 5 Number.POSITIVE_INFINITY : {v : int | [(ttag([v]) = lit$36$number);-                                              ((Prop([v])) <=> (v != 0));+                                              ((? Prop([v])) <=> (v != 0));                                               (v ~~ offset([Number; lit$36$POSITIVE_INFINITY]))]} bind 6 Number.MIN_VALUE : {v : int | [(ttag([v]) = lit$36$number);-                                      ((Prop([v])) <=> (v != 0));+                                      ((? Prop([v])) <=> (v != 0));                                       (v ~~ offset([Number; lit$36$MIN_VALUE]))]}-bind 7 Number.prototype : {VV : (Number  Immutable) | [(extends_interface([VV;+bind 7 Number.prototype : {VV : (Number  Immutable) | [(? extends_interface([VV;                                                                              lit$36$Number]));-                                                       (Prop([VV]));+                                                       (? Prop([VV]));                                                        (ttag([VV]) = lit$36$object);                                                        (VV ~~ offset([Number; lit$36$prototype]))]} bind 8 Number.NaN : {v : int | [(ttag([v]) = lit$36$number);-                                ((Prop([v])) <=> (v != 0));+                                ((? Prop([v])) <=> (v != 0));                                 (v ~~ offset([Number; lit$36$NaN]))]} bind 9 Number.NEGATIVE_INFINITY : {v : int | [(ttag([v]) = lit$36$number);-                                              ((Prop([v])) <=> (v != 0));+                                              ((? Prop([v])) <=> (v != 0));                                               (v ~~ offset([Number; lit$36$NEGATIVE_INFINITY]))]} bind 10 Number.MAX_VALUE : {v : int | [(ttag([v]) = lit$36$number);-                                       ((Prop([v])) <=> (v != 0));+                                       ((? Prop([v])) <=> (v != 0));                                        (v ~~ offset([Number; lit$36$MAX_VALUE]))]}-bind 11 Math : {VV$35$387 : (Math  Immutable) | [(extends_interface([VV$35$387;+bind 11 Math : {VV$35$387 : (Math  Immutable) | [(? extends_interface([VV$35$387;                                                                        lit$36$Math]));-                                                 (Prop([VV$35$387]));+                                                 (? Prop([VV$35$387]));                                                  (ttag([VV$35$387]) = lit$36$object)]} bind 12 Math.SQRT2 : {v : int | [(ttag([v]) = lit$36$number);-                                 ((Prop([v])) <=> (v != 0));+                                 ((? Prop([v])) <=> (v != 0));                                  (v ~~ offset([Math; lit$36$SQRT2]))]} bind 13 Math.LN2 : {v : int | [(ttag([v]) = lit$36$number);-                               ((Prop([v])) <=> (v != 0));+                               ((? Prop([v])) <=> (v != 0));                                (v ~~ offset([Math; lit$36$LN2]))]} bind 14 Math.PI : {v : int | [(ttag([v]) = lit$36$number);-                              ((Prop([v])) <=> (v != 0));+                              ((? Prop([v])) <=> (v != 0));                               (v ~~ offset([Math; lit$36$PI]))]} bind 15 Math.LOG10E : {v : int | [(ttag([v]) = lit$36$number);-                                  ((Prop([v])) <=> (v != 0));+                                  ((? Prop([v])) <=> (v != 0));                                   (v ~~ offset([Math; lit$36$LOG10E]))]} bind 16 Math.LOG2E : {v : int | [(ttag([v]) = lit$36$number);-                                 ((Prop([v])) <=> (v != 0));+                                 ((? Prop([v])) <=> (v != 0));                                  (v ~~ offset([Math; lit$36$LOG2E]))]} bind 17 Math.E : {v : int | [(ttag([v]) = lit$36$number);-                             ((Prop([v])) <=> (v != 0));+                             ((? Prop([v])) <=> (v != 0));                              (v ~~ offset([Math; lit$36$E]))]} bind 18 Math.SQRT1_2 : {v : int | [(ttag([v]) = lit$36$number);-                                   ((Prop([v])) <=> (v != 0));+                                   ((? Prop([v])) <=> (v != 0));                                    (v ~~ offset([Math; lit$36$SQRT1_2]))]} bind 19 Math.LN10 : {v : int | [(ttag([v]) = lit$36$number);-                                ((Prop([v])) <=> (v != 0));+                                ((? Prop([v])) <=> (v != 0));                                 (v ~~ offset([Math; lit$36$LN10]))]}-bind 20 String : {VV$35$469 : (StringConstructor  Immutable) | [(extends_interface([VV$35$469;+bind 20 String : {VV$35$469 : (StringConstructor  Immutable) | [(? extends_interface([VV$35$469;                                                                                       lit$36$StringConstructor]));-                                                                (Prop([VV$35$469]));+                                                                (? Prop([VV$35$469]));                                                                 (ttag([VV$35$469]) = lit$36$object)]}-bind 21 String.prototype : {VV : (String  Immutable) | [(extends_interface([VV;+bind 21 String.prototype : {VV : (String  Immutable) | [(? extends_interface([VV;                                                                               lit$36$String]));-                                                        (Prop([VV]));+                                                        (? Prop([VV]));                                                         (ttag([VV]) = lit$36$object);                                                         (VV ~~ offset([String; lit$36$prototype]))]}-bind 22 Array : {VV$35$727 : Object | [(Prop([VV$35$727]));+bind 22 Array : {VV$35$727 : Object | [(? Prop([VV$35$727]));                                        (ttag([VV$35$727]) = lit$36$object)]}-bind 23 Array.prototype : {VV : (Array  Mutable  Top) | [(extends_interface([VV;+bind 23 Array.prototype : {VV : (Array  Mutable  Top) | [(? extends_interface([VV;                                                                                lit$36$Array]));-                                                         (Prop([VV]));+                                                         (? Prop([VV]));                                                          (ttag([VV]) = lit$36$object);                                                          (VV ~~ offset([Array; lit$36$prototype]))]}-bind 24 Function : {VV$35$762 : Object | [(Prop([VV$35$762]));+bind 24 Function : {VV$35$762 : Object | [(? Prop([VV$35$762]));                                           (ttag([VV$35$762]) = lit$36$object)]}-bind 25 Function.prototype : {VV : (Function  Immutable) | [(extends_interface([VV;+bind 25 Function.prototype : {VV : (Function  Immutable) | [(? extends_interface([VV;                                                                                   lit$36$Function]));-                                                            (Prop([VV]));+                                                            (? Prop([VV]));                                                             (ttag([VV]) = lit$36$object);                                                             (VV ~~ offset([Function;                                                                            lit$36$prototype]))]}-bind 26 Console : {VV$35$891 : Object | [(Prop([VV$35$891]));+bind 26 Console : {VV$35$891 : Object | [(? Prop([VV$35$891]));                                          (ttag([VV$35$891]) = lit$36$object)]}-bind 27 Console.prototype : {VV : (Console  Immutable) | [(extends_interface([VV;+bind 27 Console.prototype : {VV : (Console  Immutable) | [(? extends_interface([VV;                                                                                 lit$36$Console]));-                                                          (Prop([VV]));+                                                          (? Prop([VV]));                                                           (ttag([VV]) = lit$36$object);                                                           (VV ~~ offset([Console;                                                                          lit$36$prototype]))]}-bind 28 console : {VV$35$893 : (Console  Immutable) | [(extends_interface([VV$35$893;+bind 28 console : {VV$35$893 : (Console  Immutable) | [(? extends_interface([VV$35$893;                                                                              lit$36$Console]));-                                                       (Prop([VV$35$893]));+                                                       (? Prop([VV$35$893]));                                                        (ttag([VV$35$893]) = lit$36$object)]}-bind 29 Error : {VV$35$983 : Object | [(Prop([VV$35$983]));+bind 29 Error : {VV$35$983 : Object | [(? Prop([VV$35$983]));                                        (ttag([VV$35$983]) = lit$36$object)]}-bind 30 Error.prototype : {VV : (Error  Immutable) | [(extends_interface([VV;+bind 30 Error.prototype : {VV : (Error  Immutable) | [(? extends_interface([VV;                                                                             lit$36$Error]));-                                                      (Prop([VV]));+                                                      (? Prop([VV]));                                                       (ttag([VV]) = lit$36$object);                                                       (VV ~~ offset([Error; lit$36$prototype]))]}-bind 31 Event : {VV$35$1025 : Object | [(Prop([VV$35$1025]));+bind 31 Event : {VV$35$1025 : Object | [(? Prop([VV$35$1025]));                                         (ttag([VV$35$1025]) = lit$36$object)]} bind 32 Event.CAPTURING_PHASE : {v : int | [(ttag([v]) = lit$36$number);-                                            ((Prop([v])) <=> (v != 0));+                                            ((? Prop([v])) <=> (v != 0));                                             (v ~~ offset([Event; lit$36$CAPTURING_PHASE]))]} bind 33 Event.AT_TARGET : {v : int | [(ttag([v]) = lit$36$number);-                                      ((Prop([v])) <=> (v != 0));+                                      ((? Prop([v])) <=> (v != 0));                                       (v ~~ offset([Event; lit$36$AT_TARGET]))]}-bind 34 Event.prototype : {VV : (Event  Immutable) | [(extends_interface([VV;+bind 34 Event.prototype : {VV : (Event  Immutable) | [(? extends_interface([VV;                                                                             lit$36$Event]));-                                                      (Prop([VV]));+                                                      (? Prop([VV]));                                                       (ttag([VV]) = lit$36$object);                                                       (VV ~~ offset([Event; lit$36$prototype]))]} bind 35 Event.BUBBLING_PHASE : {v : int | [(ttag([v]) = lit$36$number);-                                           ((Prop([v])) <=> (v != 0));+                                           ((? Prop([v])) <=> (v != 0));                                            (v ~~ offset([Event; lit$36$BUBBLING_PHASE]))]}-bind 36 document : {VV$35$1027 : (Document  Immutable) | [(extends_interface([VV$35$1027;+bind 36 document : {VV$35$1027 : (Document  Immutable) | [(? extends_interface([VV$35$1027;                                                                                 lit$36$Document]));-                                                          (Prop([VV$35$1027]));+                                                          (? Prop([VV$35$1027]));                                                           (ttag([VV$35$1027]) = lit$36$object)]}-bind 37 document.documentElement : {VV : (HTMLElement  Immutable) | [(extends_interface([VV;+bind 37 document.documentElement : {VV : (HTMLElement  Immutable) | [(? extends_interface([VV;                                                                                            lit$36$HTMLElement]));-                                                                     (Prop([VV]));+                                                                     (? Prop([VV]));                                                                      (ttag([VV]) = lit$36$object);                                                                      (VV ~~ offset([document;                                                                                     lit$36$documentElement]))]}-bind 38 window : {VV$35$1031 : (Window  Immutable) | [(extends_interface([VV$35$1031;+bind 38 window : {VV$35$1031 : (Window  Immutable) | [(? extends_interface([VV$35$1031;                                                                             lit$36$Window]));-                                                      (Prop([VV$35$1031]));+                                                      (? Prop([VV$35$1031]));                                                       (ttag([VV$35$1031]) = lit$36$object)]} bind 39 lq_tmp_nano_1 : {VV : (BitVec  Size32) | [(VV = (lit "#x00000008" (BitVec  Size32)))]} bind 40 a_SSA_0 : {VV : (BitVec  Size32) | [(VV ~~ lq_tmp_nano_1);@@ -217,7 +217,7 @@ bind 43 lq_tmp_nano_3 : {v : (BitVec  Size32) | [(v = bvor([a_SSA_0;                                                             a_SSA_0]))]} bind 44 lq_tmp_nano_6 : {v : Boolean | [(ttag([v]) = lit$36$boolean);-                                        ((Prop([v])) <=> (b_SSA_1 ~~ lq_tmp_nano_3))]}+                                        ((? Prop([v])) <=> (b_SSA_1 ~~ lq_tmp_nano_3))]} bind 45 lq_tmp_nano_9 : {VV$35$4 : Void | []}  @@ -272,8 +272,8 @@   lhs {VV$35$F1 : Boolean | [(ttag([VV$35$F1]) = lit$36$boolean);                              (VV$35$F1 ~~ lq_tmp_nano_6);                              (ttag([VV$35$F1]) = lit$36$boolean);-                             ((Prop([VV$35$F1])) <=> (b_SSA_1 ~~ lq_tmp_nano_3))]}-  rhs {VV$35$F1 : Boolean | [(Prop([VV$35$F1]))]}+                             ((? Prop([VV$35$F1])) <=> (b_SSA_1 ~~ lq_tmp_nano_3))]}+  rhs {VV$35$F1 : Boolean | [(? Prop([VV$35$F1]))]}   id 1 tag [1]   // META constraint id 1 : /Users/rjhala/research/stack/liquid/refscript/tests/pos/simple/hex.ts:7:1-7:22 @@ -327,8 +327,8 @@   lhs {VV$35$F2 : Boolean | [(ttag([VV$35$F2]) = lit$36$boolean);                              (VV$35$F2 ~~ lq_tmp_nano_6);                              (ttag([VV$35$F2]) = lit$36$boolean);-                             ((Prop([VV$35$F2])) <=> (b_SSA_1 ~~ lq_tmp_nano_3))]}-  rhs {VV$35$F2 : Boolean | [(Prop([VV$35$F2]))]}+                             ((? Prop([VV$35$F2])) <=> (b_SSA_1 ~~ lq_tmp_nano_3))]}+  rhs {VV$35$F2 : Boolean | [(? Prop([VV$35$F2]))]}   id 2 tag [1]   // META constraint id 2 : /Users/rjhala/research/stack/liquid/refscript/tests/pos/simple/hex.ts:7:1-7:22
tests/pos/kvar-param-poly-00.fq view
@@ -2,7 +2,7 @@ // a kvar's params can be instantiated / substituted with values of a different // type. Here, K0(v:alpha, x:alpha) but is instantiated with int. -qualif Bog(v:a, x:a)  { x = v }+qualif Bog(v:a, x:a) : (x = v)  bind 1 x : {v: alpha | true}
tests/pos/len00-rename.fq view
@@ -1,7 +1,7 @@  // This qualifier saves the day; solve constraints WITHOUT IT -qualif ListZ(v : [@(0)]) { len v >= 0 }+qualif ListZ(v : [@(0)]): (len v >= 0)  constant len : (func(2, [(@(0)  @(1)); int]))
tests/pos/len00.fq view
@@ -1,7 +1,7 @@  // This qualifier saves the day; solve constraints WITHOUT IT -qualif ListZ(v : [@(0)]) { len v >= 0 }+qualif ListZ(v : [@(0)]): (len v >= 0)  constant len : (func(2, [(@(0)  @(1)); int]))
tests/pos/listqual.hs.fq view
@@ -1,53 +1,53 @@-qualif Append(v : [@(0)], xs : [@(0)], ys : [@(0)]) { len([v]) = (len([xs]) + len([ys]))  } // "tests/pos/listqual.hs" (line 3, column 12)-qualif Fst(v : @(1), y : @(0)) { v = fst([y])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 29, column 8)-qualif Snd(v : @(1), y : @(0)) { v = snd([y])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 30, column 8)-qualif Auto(v : [int]) { len([v]) = 2  } // "tests/pos/listqual.hs" (line 10, column 1)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { Prop([v]) <=> len([xs]) > 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 13, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { Prop([v]) <=> len([xs]) = 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 14, column 8)-qualif ListZ(v : [@(0)]) { len([v]) = 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 16, column 8)-qualif ListZ(v : [@(0)]) { len([v]) >= 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 17, column 8)-qualif ListZ(v : [@(0)]) { len([v]) > 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 18, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) = len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 20, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) >= len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 21, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) > len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 22, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) <= len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 23, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) < len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 24, column 8)-qualif EqLen(v : int, xs : [@(0)]) { v = len([xs])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 26, column 8)-qualif LenEq(v : [@(0)], x : int) { x = len([v])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 27, column 8)-qualif LenDiff(v : [@(0)], x : int) { len([v]) = (x + 1)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 28, column 8)-qualif LenDiff(v : [@(0)], x : int) { len([v]) = (x - 1)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 29, column 8)-qualif LenAcc(v : int, xs : [@(0)], n : int) { v = (len([xs]) + n)  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 30, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 3, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 4, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 5, column 8)-qualif Bot(v : bool) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 6, column 8)-qualif Bot(v : int) { 0 = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 7, column 8)-qualif CmpZ(v : @(0)) { v < 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 9, column 8)-qualif CmpZ(v : @(0)) { v <= 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 10, column 8)-qualif CmpZ(v : @(0)) { v > 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 11, column 8)-qualif CmpZ(v : @(0)) { v >= 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 12, column 8)-qualif CmpZ(v : @(0)) { v = 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 13, column 8)-qualif CmpZ(v : @(0)) { v != 0  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 14, column 8)-qualif Cmp(v : @(0), x : @(0)) { v < x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 16, column 8)-qualif Cmp(v : @(0), x : @(0)) { v <= x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 17, column 8)-qualif Cmp(v : @(0), x : @(0)) { v > x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 18, column 8)-qualif Cmp(v : @(0), x : @(0)) { v >= x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 19, column 8)-qualif Cmp(v : @(0), x : @(0)) { v = x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 20, column 8)-qualif Cmp(v : @(0), x : @(0)) { v != x  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 21, column 8)-qualif One(v : int) { v = 1  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 28, column 8)-qualif True(v : bool) {  v  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 29, column 8)-qualif False(v : bool) { ~ v  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 30, column 8)-qualif True1(v : GHC.Types.Bool) {  Prop([v])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 31, column 8)-qualif False1(v : GHC.Types.Bool) { ~ Prop([v])  } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 32, column 8)-qualif Papp(v : @(0), p : (Pred  @(0))) { papp1([p;-                                                   v]) } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 35, column 8)-qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))) { papp2([p;+qualif Append(v : [@(0)], xs : [@(0)], ys : [@(0)]): (len([v]) = (len([xs]) + len([ys]))) // "tests/pos/listqual.hs" (line 3, column 12)+qualif Fst(v : @(1), y : @(0)): (v = fst([y])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 29, column 8)+qualif Snd(v : @(1), y : @(0)): (v = snd([y])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.spec" (line 30, column 8)+qualif Auto(v : [int]): (len([v]) = 2) // "tests/pos/listqual.hs" (line 10, column 1)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((? Prop([v])) <=> (len([xs]) > 0)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 13, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((? Prop([v])) <=> (len([xs]) = 0)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 14, column 8)+qualif ListZ(v : [@(0)]): (len([v]) = 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 16, column 8)+qualif ListZ(v : [@(0)]): (len([v]) >= 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 17, column 8)+qualif ListZ(v : [@(0)]): (len([v]) > 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 18, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) = len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 20, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) >= len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 21, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) > len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 22, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) <= len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 23, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) < len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 24, column 8)+qualif EqLen(v : int, xs : [@(0)]): (v = len([xs])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 26, column 8)+qualif LenEq(v : [@(0)], x : int): (x = len([v])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 27, column 8)+qualif LenDiff(v : [@(0)], x : int): (len([v]) = (x + 1)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 28, column 8)+qualif LenDiff(v : [@(0)], x : int): (len([v]) = (x - 1)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 29, column 8)+qualif LenAcc(v : int, xs : [@(0)], n : int): (v = (len([xs]) + n)) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/GHC/Base.hquals" (line 30, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 3, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 4, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 5, column 8)+qualif Bot(v : bool): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 6, column 8)+qualif Bot(v : int): (0 = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 7, column 8)+qualif CmpZ(v : @(0)): (v < 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 9, column 8)+qualif CmpZ(v : @(0)): (v <= 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 10, column 8)+qualif CmpZ(v : @(0)): (v > 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 11, column 8)+qualif CmpZ(v : @(0)): (v >= 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 12, column 8)+qualif CmpZ(v : @(0)): (v = 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 13, column 8)+qualif CmpZ(v : @(0)): (v != 0) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 14, column 8)+qualif Cmp(v : @(0), x : @(0)): (v < x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 16, column 8)+qualif Cmp(v : @(0), x : @(0)): (v <= x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 17, column 8)+qualif Cmp(v : @(0), x : @(0)): (v > x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 18, column 8)+qualif Cmp(v : @(0), x : @(0)): (v >= x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 19, column 8)+qualif Cmp(v : @(0), x : @(0)): (v = x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 20, column 8)+qualif Cmp(v : @(0), x : @(0)): (v != x) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 21, column 8)+qualif One(v : int): (v = 1) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 28, column 8)+qualif True(v : bool): (? v) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 29, column 8)+qualif False(v : bool): (~ ((? v))) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 30, column 8)+qualif True1(v : GHC.Types.Bool): (? Prop([v])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 31, column 8)+qualif False1(v : GHC.Types.Bool): (~ ((? Prop([v])))) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 32, column 8)+qualif Papp(v : @(0), p : (Pred  @(0))): (? papp1([p;+                                                   v])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 35, column 8)+qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))): (? papp2([p;                                                                     v;-                                                                    x]) } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 38, column 8)-qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))) { papp3([p;+                                                                    x])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 38, column 8)+qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))): (? papp3([p;                                                                                     v;                                                                                     x;-                                                                                    y]) } // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 41, column 8)+                                                                                    y])) // "/Users/rjhala/research/stack/liquid/liquidhaskell/.stack-work/install/x86_64-osx/nightly-2015-09-24/7.10.2/share/x86_64-osx-ghc-7.10.2/liquidhaskell-0.5.0.2/include/Prelude.hquals" (line 41, column 8)   cut $k__185@@ -163,10 +163,10 @@ bind 13 lq_anf__dwU : {lq_tmp_x_198 : [a_awA] | [(lq_tmp_x_198 = ds_dwT);                                                  (len([lq_tmp_x_198]) >= 0);                                                  (len([lq_tmp_x_198]) = 0);-                                                 (null([lq_tmp_x_198]) <=> true);+                                                 ((? null([lq_tmp_x_198])) <=> true);                                                  (lq_tmp_x_198 = GHC.Types.$91$$93$$35$6m([]));                                                  (len([lq_tmp_x_198]) = 0);-                                                 (null([lq_tmp_x_198]) <=> true);+                                                 ((? null([lq_tmp_x_198])) <=> true);                                                  (len([lq_tmp_x_198]) >= 0)]} bind 14 lq_anf__dwU : {lq_tmp_x_208 : [a_awA] | [(lq_tmp_x_208 = ds_dwT);                                                  (len([lq_tmp_x_208]) >= 0);@@ -176,13 +176,13 @@ bind 17 lq_anf__dwU : {lq_tmp_x_208 : [a_awA] | [(lq_tmp_x_208 = ds_dwT);                                                  (len([lq_tmp_x_208]) >= 0);                                                  (len([lq_tmp_x_208]) = (1 + len([xs$35$awp])));-                                                 (null([lq_tmp_x_208]) <=> false);+                                                 ((? null([lq_tmp_x_208])) <=> false);                                                  (xsListSelector([lq_tmp_x_208]) = xs$35$awp);                                                  (xListSelector([lq_tmp_x_208]) = x$35$awo);                                                  (lq_tmp_x_208 = GHC.Types.$58$$35$64([x$35$awo;                                                                                        xs$35$awp]));                                                  (len([lq_tmp_x_208]) = (1 + len([xs$35$awp])));-                                                 (null([lq_tmp_x_208]) <=> false);+                                                 ((? null([lq_tmp_x_208])) <=> false);                                                  (xsListSelector([lq_tmp_x_208]) = xs$35$awp);                                                  (xListSelector([lq_tmp_x_208]) = x$35$awo);                                                  (len([lq_tmp_x_208]) >= 0)]}@@ -192,22 +192,22 @@ bind 20 lq_anf__dwW : {lq_tmp_x_264 : int | [(lq_tmp_x_264 = (1  :  int))]} bind 21 lq_tmp_x_278 : {VV$35$279 : int | []} bind 22 lq_anf__dwX : {lq_tmp_x_270 : [int] | [(len([lq_tmp_x_270]) = 0);-                                               (null([lq_tmp_x_270]) <=> true);+                                               ((? null([lq_tmp_x_270])) <=> true);                                                (len([lq_tmp_x_270]) >= 0)]} bind 23 lq_tmp_x_296 : {VV$35$297 : int | []} bind 24 lq_anf__dwY : {lq_tmp_x_284 : [int] | [(len([lq_tmp_x_284]) = (1 + len([lq_anf__dwX])));-                                               (null([lq_tmp_x_284]) <=> false);+                                               ((? null([lq_tmp_x_284])) <=> false);                                                (xsListSelector([lq_tmp_x_284]) = lq_anf__dwX);                                                (xListSelector([lq_tmp_x_284]) = lq_anf__dwW);                                                (len([lq_tmp_x_284]) >= 0)]} bind 25 lq_anf__dwZ : {lq_tmp_x_305 : int | [(lq_tmp_x_305 = (2  :  int))]} bind 26 lq_tmp_x_319 : {VV$35$320 : int | []} bind 27 lq_anf__dx0 : {lq_tmp_x_311 : [int] | [(len([lq_tmp_x_311]) = 0);-                                               (null([lq_tmp_x_311]) <=> true);+                                               ((? null([lq_tmp_x_311])) <=> true);                                                (len([lq_tmp_x_311]) >= 0)]} bind 28 lq_tmp_x_337 : {VV$35$338 : int | []} bind 29 lq_anf__dx1 : {lq_tmp_x_325 : [int] | [(len([lq_tmp_x_325]) = (1 + len([lq_anf__dx0])));-                                               (null([lq_tmp_x_325]) <=> false);+                                               ((? null([lq_tmp_x_325])) <=> false);                                                (xsListSelector([lq_tmp_x_325]) = lq_anf__dx0);                                                (xListSelector([lq_tmp_x_325]) = lq_anf__dwZ);                                                (len([lq_tmp_x_325]) >= 0)]}@@ -269,12 +269,12 @@ bind 72 VV$35$427 : {VV$35$427 : int | [(VV$35$427 = 1)]} bind 73 VV$35$427 : {VV$35$427 : int | [(VV$35$427 = 1)]} bind 74 VV$35$430 : {VV$35$430 : [a_awA] | [(len([VV$35$430]) = (1 + len([lq_anf__dwV])));-                                            (null([VV$35$430]) <=> false);+                                            ((? null([VV$35$430])) <=> false);                                             (xsListSelector([VV$35$430]) = lq_anf__dwV);                                             (xListSelector([VV$35$430]) = x$35$awo);                                             (len([VV$35$430]) >= 0)]} bind 75 VV$35$430 : {VV$35$430 : [a_awA] | [(len([VV$35$430]) = (1 + len([lq_anf__dwV])));-                                            (null([VV$35$430]) <=> false);+                                            ((? null([VV$35$430])) <=> false);                                             (xsListSelector([VV$35$430]) = lq_anf__dwV);                                             (xListSelector([VV$35$430]) = x$35$awo);                                             (len([VV$35$430]) >= 0)]}@@ -384,7 +384,7 @@ constraint:   env [0; 16; 1; 17; 2; 18; 3; 4; 5; 6; 7; 8; 9; 10; 74; 11; 14; 15]   lhs {VV$35$F18 : [a_awA] | [(len([VV$35$F18]) = (1 + len([lq_anf__dwV])));-                              (null([VV$35$F18]) <=> false);+                              ((? null([VV$35$F18])) <=> false);                               (xsListSelector([VV$35$F18]) = lq_anf__dwV);                               (xListSelector([VV$35$F18]) = x$35$awo);                               (len([VV$35$F18]) >= 0)]}
tests/pos/literals03.fq view
@@ -12,5 +12,5 @@ constraint:   env [ 1; 2 ]   lhs {v : int | true }-  rhs {v : int | Set_mem a (listElts things)}+  rhs {v : int | Set_mem a (listElts things)}    id 1 tag []
tests/pos/literals04.fq view
@@ -12,5 +12,5 @@ constraint:   env [ 1; 2 ]   lhs {v : int | true }-  rhs {v : int | Set_mem a (listElts things)}+  rhs {v : int | Set_mem a (listElts things)}    id 1 tag []
tests/pos/literals05.fq view
@@ -2,13 +2,13 @@ constant Set_sng : (func(1, [@(0); (Set_Set  @(0))]))  bind 1 a  : {a : Str | a == "director" }-bind 2 things : {v : LLChar | (listElts v == (Set_cup (Set_sng "year")-                                               (Set_cup (Set_sng "star")-                                                 (Set_cup (Set_sng "director")+bind 2 things : {v : LLChar | (listElts v == (Set_cup (Set_sng "year") +                                               (Set_cup (Set_sng "star") +                                                 (Set_cup (Set_sng "director")                                                     (Set_sng "title"))))) }  constraint:   env [ 1; 2 ]   lhs {v : int | true }-  rhs {v : int | Set_mem a (listElts things)}+  rhs {v : int | Set_mem a (listElts things)}    id 1 tag []
− tests/pos/localrw.fq 
@@ -1,16 +0,0 @@-fixpoint "--localrewrites"-fixpoint "--rewrite"-fixpoint "--allowho"--bind 1 g : { V : Int | true }-bind 2 g : { V : Int | true }--defineLocal 1 [g := (40 + 1)]--expand [1 : True]--constraint:-    env [1]-    lhs { V : Tuple | true }-    rhs { V : Tuple | (g = 41) }-    id 1 tag []
tests/pos/maps.fq view
@@ -1,29 +1,37 @@ -bind 1 m1 : {v : Map_t Int Int | v = Map_default 0 }-bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) }-bind 3 m3 : {v : Map_t Int Int | v = (Map_store (Map_store m1 20 1) 10 1) }+bind 1 m1 : {v : Map_t Int Int | v = Map_default 0}+bind 2 m2 : {v : Map_t Int Int | v = (Map_store (Map_store m1 10 1) 20 1) } +bind 3 m3 : {v : Map_t Int Int | v = (Map_store (Map_store m1 20 1) 10 1) } +bind 4 m4 : {v : Map_t Int Int | v = (Map_store m1 10 1) } +bind 5 m5 : {v : Map_t Int Int | v = (Map_store m1 20 1) }   constraint:   env [ 1 ]   lhs {v : int | v = Map_select m1 100 }-  rhs {v : int | v = 0 }+  rhs {v : int | v = 0 }    id 1 tag []  constraint:   env [ 1; 2 ]   lhs {v : int | v = Map_select m2 100 }-  rhs {v : int | v = 0 }+  rhs {v : int | v = 0 }    id 2 tag []  constraint:   env [ 1; 2 ]   lhs {v : int | v = Map_select m2 10 }-  rhs {v : int | v = 1 }+  rhs {v : int | v = 1 }    id 3 tag []  constraint:   env [ 1; 2; 3 ]   lhs {v : int | true }-  rhs {v : int | m2 = m3 }+  rhs {v : int | m2 = m3 }    id 4 tag []++constraint:+  env [ 1; 2; 3; 4; 5 ]+  lhs {v : int | true }+  rhs {v : int | m2 = Map_union m4 m5 } +  id 5 tag []
− tests/pos/maps02.fq 
@@ -1,29 +0,0 @@--bind 1 m1 : {v : Map_t Str real | v = Map_default 0.0 }-bind 2 m2 : {v : Map_t Str real | v = (Map_store (Map_store m1 "AA" 2.0) "BB" 3.5) }-bind 3 m3 : {v : Map_t Str real | v = (Map_store (Map_store m1 "BB" 3.5) "AA" 2.0) }--constraint:-  env [ 1 ]-  lhs {v : real | v = Map_select m1 "CC" }-  rhs {v : real | v = 0.0 }-  id 1 tag []--constraint:-  env [ 1; 2 ]-  lhs {v : real | v = Map_select m2 "CC" }-  rhs {v : real | v = 0.0 }-  id 2 tag []--constraint:-  env [ 1; 2 ]-  lhs {v : real | v = Map_select m2 "AA" }-  rhs {v : real | v = 2.0 }-  id 3 tag []--constraint:-  env [ 1; 2; 3 ]-  lhs {v : real | true }-  rhs {v : real | m2 = m3 }-  id 4 tag []-
tests/pos/meas00.fq view
@@ -1,4 +1,5 @@-fixpoint "--eliminate=some"+qualif Sz(v: Tree): (0 < thinginess v)+qualif Sz(v: Tree): (1 < 0)  constant thinginess : func(0, [Tree; int]) @@ -15,6 +16,6 @@   rhs {v : Tree | 0 < thinginess v }   id 2 tag [] -wf:+wf:    env [ ]   reft { v: Tree | $k1 }
tests/pos/meas02.fq view
@@ -1,7 +1,7 @@ -qualif SumZ(v:[real]) { sumD v = 0.0 }+qualif SumZ(v:[real]): (sumD v = 0.0) -qualif SumZ(v:[real]) { ((sumD v) / (sumD v)) = 1.0 }+qualif SumZ(v:[real]): (((sumD v) / (sumD v)) = 1.0)  constant sumD : (func(0, [[real]; real]))
tests/pos/min00.fq view
@@ -1,8 +1,8 @@ -qualif Zog(v:a)  { 10 <= v }-qualif Zog(v:a)  { 9 <= v }-qualif Zog(v:a)  { 8 <= v }-qualif Zog(v:a)  { 99 <= v }+qualif Zog(v:a) : (10 <= v)+qualif Zog(v:a) : (9 <= v)+qualif Zog(v:a) : (8 <= v)+qualif Zog(v:a) : (99 <= v)  constraint:   env []
tests/pos/num00.fq view
@@ -1,6 +1,6 @@ // This qualifier saves the day; solve constraints WITHOUT IT -qualif Zog(v:a)  { 0 <= v }+qualif Zog(v:a) : (0 <= v)  bind 0 alpha : {v : num | true}
tests/pos/numoverload00.fq view
@@ -1,6 +1,6 @@ -qualif Foo(v:real, xiggety:real) { v = xiggety * xiggety }-qualif Bar(v:real) { v = 0.0 }+qualif Foo(v:real, xiggety:real): (v = xiggety * xiggety)+qualif Bar(v:real): (v = 0.0)  bind 0 zero  : {VV : real | VV = 0.0 } bind 1 one   : {VV : real | VV = (1.0 / 1.0) }
− tests/pos/polybag.fq 
@@ -1,37 +0,0 @@-data PolyBag.Lst 1 = [-       | PolyBag.Cons {PolyBag.hd : @(0), PolyBag.tl : (PolyBag.Lst @(0))}-       | PolyBag.Emp {}-     ]--constant PolyBag.hd : (func(1 , [(PolyBag.Lst @(0)); @(0)]))-constant PolyBag.tl : (func(1 , [(PolyBag.Lst @(0)); (PolyBag.Lst @(0))]))-constant is$PolyBag.Cons : (func(1 , [(PolyBag.Lst @(0)); bool]))-constant is$PolyBag.Emp : (func(1 , [(PolyBag.Lst @(0)); bool]))-distinct PolyBag.Cons : (func(1 , [@(0);-                                   (PolyBag.Lst @(0));-                                   (PolyBag.Lst @(0))]))-distinct PolyBag.Emp : (func(1 , [(PolyBag.Lst @(0))]))--bind 1 PolyBag.Emp : {VV : func(1 , [(PolyBag.Lst @(0))]) | []}-bind 2 PolyBag.Cons : {VV : func(1 , [@(0);-                                       (PolyBag.Lst @(0));-                                       (PolyBag.Lst @(0))]) | []}-bind 3 PolyBag.lstHd : {VV : func(1 , [(PolyBag.Lst @(0));-                                         (Bag_t @(0))]) | []}-bind 4 p : {VV : (PolyBag.Lst l) | []}-bind 5 nil : {x : (PolyBag.Lst (PolyBag.Lst l)) | [(is$PolyBag.Emp x);-                                                   (~ ((is$PolyBag.Cons x)));-                                                   (x = PolyBag.Emp);-                                                   ((PolyBag.lstHd x) = (Bag_empty 0))]}--constraint:-  env [1; 2; 3; 4; 5]-  lhs {VV : (PolyBag.Lst (PolyBag.Lst l)) | [(is$PolyBag.Cons VV);-                                             (~ ((is$PolyBag.Emp VV)));-                                             (VV = (PolyBag.Cons p nil));-                                             ((PolyBag.hd VV) = p);-                                             ((PolyBag.tl VV) = nil);-                                             ((PolyBag.lstHd VV) =-                                                (Bag_union (Bag_empty 0) (Bag_sng p 1)))]}-  rhs {VV : (PolyBag.Lst (PolyBag.Lst l)) | [(VV = (PolyBag.Cons p PolyBag.Emp))]}-  id 6 tag [6]
− tests/pos/polyset.fq 
@@ -1,32 +0,0 @@-data PolySet.Lst 1 = [-       | PolySet.Cons {PolySet.hd : @(0), PolySet.tl : (PolySet.Lst @(0))}-       | PolySet.Emp {}-     ]--constant PolySet.hd : (func(1 , [(PolySet.Lst @(0)); @(0)]))-constant PolySet.tl : (func(1 , [(PolySet.Lst @(0)); (PolySet.Lst @(0))]))-constant is$PolySet.Cons : (func(1 , [(PolySet.Lst @(0)); bool]))-constant is$PolySet.Emp : (func(1 , [(PolySet.Lst @(0)); bool]))-constant PolySet.Cons : (func(1 , [@(0);-                                   (PolySet.Lst @(0));-                                   (PolySet.Lst @(0))]))-constant PolySet.lstHd : (func(1 , [(PolySet.Lst @(0));-                                    (Set_Set @(0))]))--bind 1 PolySet.Emp : {VV : func(1 , [(PolySet.Lst @(0))]) | []}-bind 2 PolySet.Cons : {VV : func(1 , [@(0);-                                       (PolySet.Lst @(0));-                                       (PolySet.Lst @(0))]) | []}-bind 3 p : {VV : (PolySet.Lst l) | []}--constraint:-  env [1; 2; 3]-  lhs {VV : (PolySet.Lst (PolySet.Lst l)) | [(is$PolySet.Cons VV);-                                             (~ ((is$PolySet.Emp VV)));-                                             (VV = (PolySet.Cons p PolySet.Emp));-                                             ((PolySet.hd VV) = p);-                                             ((PolySet.tl VV) = PolySet.Emp);-                                             ((PolySet.lstHd VV) = (Set_sng p))]}-  rhs {VV : (PolySet.Lst (PolySet.Lst l)) | [(VV = (PolySet.Cons p PolySet.Emp))]}-  id 4 tag [4]-
tests/pos/qualif-inst.fq view
@@ -1,6 +1,6 @@ // adapted from LH test eqelems.hs -qualif Cmp(v : @(0), fix##126#X : @(0)) { v >= fix##126#X }+qualif Cmp(v : @(0), fix##126#X : @(0)): (v >= fix##126#X)  constant elems : (func(1, [(Goo.T  @(0)); (Set_Set  @(0))]))
tests/pos/qualif-template-00.fq view
@@ -1,6 +1,6 @@ // qualif Goob(v:a, z: b) : (v = z) // qualif Prefix2(v:a, x as (mon . $1) : b, y as (sun . $1)) : (v = x + y)-qualif Prefix(v:a, z as (mon . $1) : b)  { v = z }+qualif Prefix(v:a, z as (mon . $1) : b) : (v = z)  bind 0  monday  : {v : int | true} bind 10 tuesday : {v : int | true}
tests/pos/qualif-template-01.fq view
@@ -1,6 +1,6 @@ // qualif Goob(v:a, z: b) : (v = z) // qualif Prefix2(v:a, x as (mon . $1) : b, y as (sun . $1)) : (v = x + y)-qualif Prefix(v:a, z as ($1 . nday) : b)  { v = z }+qualif Prefix(v:a, z as ($1 . nday) : b) : (v = z)  bind 0  monday  : {v : int | true} bind 10 tuesday : {v : int | true}
tests/pos/qualif-template-02.fq view
@@ -1,4 +1,4 @@-qualif Prefix2(v:a, x as (sun . $1)  : b, y as (mon . $1) : b)  { v = x + y }+qualif Prefix2(v:a, x as (sun . $1)  : b, y as (mon . $1) : b) : (v = x + y)  bind 0  sunday  : {v : int | v = 6  } bind 1  monday  : {v : int | v = 4  }
tests/pos/sets.fq view
@@ -2,6 +2,6 @@  constraint:   env []-  lhs {v : Set_Set a_aTp | [(Set_emp([v]))]}+  lhs {v : Set_Set a_aTp | [(? Set_emp([v]))]}   rhs {v : Set_Set a_aTp | [(v = Set_empty([0]))]}   id 3 tag [2]
tests/pos/sets01.fq view
@@ -2,38 +2,38 @@ constant Set_sng : (func(1, [@(0); (Set_Set  @(0))]))  bind 1 m1 : {v : Set_Set Int | v = Set_empty 0}-bind 2 m2 : {v : Set_Set Int | v = (Set_cup (Set_cup m1 (Set_sng 10)) (Set_sng 20)) }-bind 3 m3 : {v : Set_Set Int | v = (Set_cup (Set_cup m1 (Set_sng 20)) (Set_sng 10)) }-bind 4 m4 : {v : Set_Set Int | v = (Set_cup m1 (Set_sng 10)) }-bind 5 m5 : {v : Set_Set Int | v = (Set_cup m1 (Set_sng 20)) }+bind 2 m2 : {v : Set_Set Int | v = (Set_cup (Set_cup m1 (Set_sng 10)) (Set_sng 20)) } +bind 3 m3 : {v : Set_Set Int | v = (Set_cup (Set_cup m1 (Set_sng 20)) (Set_sng 10)) } +bind 4 m4 : {v : Set_Set Int | v = (Set_cup m1 (Set_sng 10)) } +bind 5 m5 : {v : Set_Set Int | v = (Set_cup m1 (Set_sng 20)) }   constraint:   env [ 1 ]   lhs {v : int | true }-  rhs {v : int | not (Set_mem 100 m1)  }+  rhs {v : int | not (Set_mem 100 m1)  }    id 1 tag []  constraint:   env [ 1; 2 ]-  lhs {v : int | true }+  lhs {v : int | true }    rhs {v : int | not (Set_mem 100 m2) }   id 2 tag []  constraint:   env [ 1; 2 ]-  lhs {v : int | true }+  lhs {v : int | true }    rhs {v : int | Set_mem 10 m2 }   id 3 tag []  constraint:   env [ 1; 2; 3 ]   lhs {v : int | true }-  rhs {v : int | m2 = m3 }+  rhs {v : int | m2 = m3 }    id 4 tag []  constraint:   env [ 1; 2; 3; 4; 5 ]   lhs {v : int | true }-  rhs {v : int | m2 = Set_cup m4 m5 }+  rhs {v : int | m2 = Set_cup m4 m5 }    id 5 tag []
tests/pos/test00.fq view
@@ -1,5 +1,5 @@-qualif Zog(v:a)  { 10 <= v }-qualif Bog(v:a, x:a)  { x <= v }+qualif Zog(v:a) : (10 <= v)+qualif Bog(v:a, x:a) : (x <= v)  bind 0 a : {va: int | $k0[v := va][thing := thang] } bind 1 thing : {v: int | true }
tests/pos/test00.hs.fq view
@@ -1,61 +1,61 @@ -qualif IsEmp(v:GHC.Types.Bool, xs: [a])  { Prop(v) <=> len([xs]) > 0 }-qualif IsEmp(v:GHC.Types.Bool, xs: [a])  { Prop(v) <=> len([xs]) = 0 }-qualif ListZ(v: [a])           { len([v]) =  0  }-qualif ListZ(v: [a])           { len([v]) >= 0  }-qualif ListZ(v: [a])           { len([v]) >  0  }-qualif CmpLen(v:[a], xs:[b])   { len([v]) =  len([xs])  }-qualif CmpLen(v:[a], xs:[b])   { len([v]) >= len([xs])  }-qualif CmpLen(v:[a], xs:[b])   { len([v]) >  len([xs])  }-qualif CmpLen(v:[a], xs:[b])   { len([v]) <= len([xs])  }-qualif CmpLen(v:[a], xs:[b])   { len([v]) <  len([xs])  }-qualif EqLen(v:int, xs: [a]) { v = len([xs])  }-qualif LenEq(v:[a], x: int)  { x = len([v])  }-qualif LenDiff(v:[a], x:int) { len([v]) = x + 1 }-qualif LenDiff(v:[a], x:int) { len([v]) = x - 1 }-qualif LenAcc(v:int, xs:[a], n: int) { v = len([xs]) + n }+qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (Prop(v) <=> len([xs]) > 0)+qualif IsEmp(v:GHC.Types.Bool, xs: [a]) : (Prop(v) <=> len([xs]) = 0)+qualif ListZ(v: [a])          : len([v]) =  0 +qualif ListZ(v: [a])          : len([v]) >= 0 +qualif ListZ(v: [a])          : len([v]) >  0 +qualif CmpLen(v:[a], xs:[b])  : len([v]) =  len([xs]) +qualif CmpLen(v:[a], xs:[b])  : len([v]) >= len([xs]) +qualif CmpLen(v:[a], xs:[b])  : len([v]) >  len([xs]) +qualif CmpLen(v:[a], xs:[b])  : len([v]) <= len([xs]) +qualif CmpLen(v:[a], xs:[b])  : len([v]) <  len([xs]) +qualif EqLen(v:int, xs: [a]): v = len([xs]) +qualif LenEq(v:[a], x: int) :  x = len([v]) +qualif LenDiff(v:[a], x:int): len([v]) = x + 1+qualif LenDiff(v:[a], x:int): len([v]) = x - 1+qualif LenAcc(v:int, xs:[a], n: int): (v = len([xs]) + n) -qualif Bot(v:obj) { 0 = 1  }-qualif Bot(v:a) { 0 = 1  }-qualif Bot(v:bool) { 0 = 1  }-qualif Bot(v:int) { 0 = 1  }-qualif CmpZ(v:a) { v <  0 }-qualif CmpZ(v:a) { v <= 0 }-qualif CmpZ(v:a) { v >  0 }-qualif CmpZ(v:a) { v >= 0 }-qualif CmpZ(v:a) { v  = 0 }-qualif CmpZ(v:a) { v != 0 }+qualif Bot(v:obj): 0 = 1 +qualif Bot(v:a): 0 = 1 +qualif Bot(v:bool): 0 = 1 +qualif Bot(v:int): 0 = 1 +qualif CmpZ(v:a): (v <  0)+qualif CmpZ(v:a): (v <= 0)+qualif CmpZ(v:a): (v >  0)+qualif CmpZ(v:a): (v >= 0)+qualif CmpZ(v:a): (v  = 0)+qualif CmpZ(v:a): (v != 0) -qualif Cmp(v:a, x:a) { v <  x }-qualif Cmp(v:a, x:a) { v <= x }-qualif Cmp(v:a, x:a) { v >  x }-qualif Cmp(v:a, x:a) { v >= x }-qualif Cmp(v:a, x:a) { v  = x }-qualif Cmp(v:a, x:a) { v != x }+qualif Cmp(v:a, x:a): (v <  x)+qualif Cmp(v:a, x:a): (v <= x)+qualif Cmp(v:a, x:a): (v >  x)+qualif Cmp(v:a, x:a): (v >= x)+qualif Cmp(v:a, x:a): (v  = x)+qualif Cmp(v:a, x:a): (v != x) -qualif One(v:int)      { v = 1 }-qualif True(v:bool)    { v  }-qualif False(v:bool)   { ~ (v)  }-qualif True1(v:GHC.Types.Bool) { Prop(v) }-qualif False1(v:GHC.Types.Bool) { ~ Prop(v) }-qualif Papp(v:a, p:Pred a)  { papp1 p v }+qualif One(v:int)     : v = 1+qualif True(v:bool)   : (? v) +qualif False(v:bool)  : ~ (? v) +qualif True1(v:GHC.Types.Bool): (Prop(v))+qualif False1(v:GHC.Types.Bool): (~ Prop(v))+qualif Papp(v:a, p:Pred a) : (papp1 p v)  constant papp1 : func(1, [Pred @(0); @(0); bool]) -qualif Papp2(v:a,x:b,p:Pred a b)  { papp2 p v x }+qualif Papp2(v:a,x:b,p:Pred a b) : (papp2 p v x) constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool]) -qualif Papp3(v:a,x:b, y:c, p:Pred a b c)  { papp3 p v x y }+qualif Papp3(v:a,x:b, y:c, p:Pred a b c) : (papp3 p v x y) constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool]) -qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d)  { papp4 p v x y z }+qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : (papp4 p v x y z) constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])    constant Prop : func(0, [GHC.Types.Bool; bool])-qualif Fst(v : @(1), fix##126#Y : @(0)) { v = fst([fix##126#Y])  } // "/Users/rjhala/research/liquid/liquidhaskell/.cabal-sandbox/share/x86_64-osx-ghc-7.8.3/liquidhaskell-0.3.1.0/include/GHC/Base.spec" (line 26, column 8)-qualif Snd(v : @(1), fix##126#Y : @(0)) { v = snd([fix##126#Y])  } // "/Users/rjhala/research/liquid/liquidhaskell/.cabal-sandbox/share/x86_64-osx-ghc-7.8.3/liquidhaskell-0.3.1.0/include/GHC/Base.spec" (line 27, column 8)+qualif Fst(v : @(1), fix##126#Y : @(0)): (v = fst([fix##126#Y])) // "/Users/rjhala/research/liquid/liquidhaskell/.cabal-sandbox/share/x86_64-osx-ghc-7.8.3/liquidhaskell-0.3.1.0/include/GHC/Base.spec" (line 26, column 8)+qualif Snd(v : @(1), fix##126#Y : @(0)): (v = snd([fix##126#Y])) // "/Users/rjhala/research/liquid/liquidhaskell/.cabal-sandbox/share/x86_64-osx-ghc-7.8.3/liquidhaskell-0.3.1.0/include/GHC/Base.spec" (line 27, column 8)  constant Prop : func(0, [GHC.Types.Bool; bool]) constant x_Tuple54 : func(5, [FAppTy (FAppTy (FAppTy (FAppTy (FAppTy fix##40##41#  @(0))  @(1))  @(2))  @(3))  @(4);@@ -138,8 +138,8 @@ bind 7 GHC.Types.EQ#6U : {VV#179 : GHC.Types.Ordering | []} bind 8 GHC.Types.LT#6S : {VV#180 : GHC.Types.Ordering | []} bind 9 GHC.Types.GT#6W : {VV#181 : GHC.Types.Ordering | []}-bind 10 GHC.Types.True#6u : {v : GHC.Types.Bool | [(Prop([v]))]}-bind 11 GHC.Types.False#68 : {v : GHC.Types.Bool | [(~ ((Prop([v]))))]}+bind 10 GHC.Types.True#6u : {v : GHC.Types.Bool | [(? Prop([v]))]}+bind 11 GHC.Types.False#68 : {v : GHC.Types.Bool | [(~ ((? Prop([v]))))]} bind 12 Language.Haskell.Liquid.Prelude.plus#rou : {VV : func(0, [int;                                                                   int;                                                                   int]) | []}@@ -206,25 +206,25 @@ bind 39 gooberding#a15N : {VV#234 : a_a164 | [$k_235]} bind 40 lq_anf__d16w : {lq_tmp_x241 : int | [(lq_tmp_x241 = 0)]} bind 41 lq_anf__d16x : {VV : a_a164 | [(VV = lq_anf__d16w)]}-bind 42 lq_anf__d16y : {lq_tmp_x254 : GHC.Types.Bool | [((Prop([lq_tmp_x254])) <=> (gooberding#a15N >= lq_anf__d16x))]}+bind 42 lq_anf__d16y : {lq_tmp_x254 : GHC.Types.Bool | [((? Prop([lq_tmp_x254])) <=> (gooberding#a15N >= lq_anf__d16x))]} bind 43 lq_anf__d16z : {lq_tmp_x276 : int | [(lq_tmp_x276 = (0  :  int))]} bind 44 Test0.x#r12i : {VV#272 : int | [$k_273]} bind 45 lq_anf__d16A : {lq_tmp_x291 : int | [(lq_tmp_x291 = (0  :  int))]}-bind 46 lq_anf__d16B : {lq_tmp_x297 : GHC.Types.Bool | [((Prop([lq_tmp_x297])) <=> (Test0.x#r12i > lq_anf__d16A))]}-bind 47 lq_anf__d16C : {lq_tmp_x313 : GHC.Types.Bool | [((Prop([lq_tmp_x313])) <=> (Test0.x#r12i > lq_anf__d16A));+bind 46 lq_anf__d16B : {lq_tmp_x297 : GHC.Types.Bool | [((? Prop([lq_tmp_x297])) <=> (Test0.x#r12i > lq_anf__d16A))]}+bind 47 lq_anf__d16C : {lq_tmp_x313 : GHC.Types.Bool | [((? Prop([lq_tmp_x313])) <=> (Test0.x#r12i > lq_anf__d16A));                                                         (lq_tmp_x313 = lq_anf__d16B)]}-bind 48 lq_anf__d16C : {lq_tmp_x315 : GHC.Types.Bool | [((Prop([lq_tmp_x315])) <=> (Test0.x#r12i > lq_anf__d16A));+bind 48 lq_anf__d16C : {lq_tmp_x315 : GHC.Types.Bool | [((? Prop([lq_tmp_x315])) <=> (Test0.x#r12i > lq_anf__d16A));                                                         (lq_tmp_x315 = lq_anf__d16B)]}-bind 49 lq_anf__d16C : {lq_tmp_x315 : GHC.Types.Bool | [((Prop([lq_tmp_x315])) <=> (Test0.x#r12i > lq_anf__d16A));+bind 49 lq_anf__d16C : {lq_tmp_x315 : GHC.Types.Bool | [((? Prop([lq_tmp_x315])) <=> (Test0.x#r12i > lq_anf__d16A));                                                         (lq_tmp_x315 = lq_anf__d16B);-                                                        (~ ((Prop([lq_tmp_x315]))));-                                                        (~ ((Prop([lq_tmp_x315]))))]}-bind 50 lq_anf__d16C : {lq_tmp_x321 : GHC.Types.Bool | [((Prop([lq_tmp_x321])) <=> (Test0.x#r12i > lq_anf__d16A));+                                                        (~ ((? Prop([lq_tmp_x315]))));+                                                        (~ ((? Prop([lq_tmp_x315]))))]}+bind 50 lq_anf__d16C : {lq_tmp_x321 : GHC.Types.Bool | [((? Prop([lq_tmp_x321])) <=> (Test0.x#r12i > lq_anf__d16A));                                                         (lq_tmp_x321 = lq_anf__d16B)]}-bind 51 lq_anf__d16C : {lq_tmp_x321 : GHC.Types.Bool | [((Prop([lq_tmp_x321])) <=> (Test0.x#r12i > lq_anf__d16A));+bind 51 lq_anf__d16C : {lq_tmp_x321 : GHC.Types.Bool | [((? Prop([lq_tmp_x321])) <=> (Test0.x#r12i > lq_anf__d16A));                                                         (lq_tmp_x321 = lq_anf__d16B);-                                                        (Prop([lq_tmp_x321]));-                                                        (Prop([lq_tmp_x321]))]}+                                                        (? Prop([lq_tmp_x321]));+                                                        (? Prop([lq_tmp_x321]))]} bind 52 Test0.prop_abs#r12j : {VV#287 : GHC.Types.Bool | [$k_288]} bind 53 VV#343 : {VV#343 : GHC.Types.Bool | [$k_239[VV#238:=VV#343][fix##36#dOrd_a165:=fix#GHC.Classes.#36#fOrdInt#35#rhx][fix##36#dNum_a166:=fix#GHC.Num.#36#fNumInt#35#rhy][gooberding#a15N:=Test0.x#r12i][lq_tmp_x332:=fix#GHC.Classes.#36#fOrdInt#35#rhx][lq_tmp_x333:=fix#GHC.Num.#36#fNumInt#35#rhy][lq_tmp_x334:=Test0.x#r12i][lq_tmp_x328:=VV#343]]} bind 54 VV#343 : {VV#343 : GHC.Types.Bool | [$k_239[VV#238:=VV#343][fix##36#dOrd_a165:=fix#GHC.Classes.#36#fOrdInt#35#rhx][fix##36#dNum_a166:=fix#GHC.Num.#36#fNumInt#35#rhy][gooberding#a15N:=Test0.x#r12i][lq_tmp_x332:=fix#GHC.Classes.#36#fOrdInt#35#rhx][lq_tmp_x333:=fix#GHC.Num.#36#fNumInt#35#rhy][lq_tmp_x334:=Test0.x#r12i][lq_tmp_x328:=VV#343]]}@@ -232,9 +232,9 @@                                   (VV#346 = Test0.x#r12i)]} bind 56 VV#346 : {VV#346 : int | [$k_273[VV#272:=VV#346][lq_tmp_x341:=VV#346];                                   (VV#346 = Test0.x#r12i)]}-bind 57 VV#349 : {VV#349 : GHC.Types.Bool | [(~ ((Prop([VV#349]))));+bind 57 VV#349 : {VV#349 : GHC.Types.Bool | [(~ ((? Prop([VV#349]))));                                              (VV#349 = GHC.Types.False#68)]}-bind 58 VV#349 : {VV#349 : GHC.Types.Bool | [(~ ((Prop([VV#349]))));+bind 58 VV#349 : {VV#349 : GHC.Types.Bool | [(~ ((? Prop([VV#349]))));                                              (VV#349 = GHC.Types.False#68)]} bind 59 VV#352 : {VV#352 : int | [(VV#352 = (0  :  int));                                   (VV#352 = lq_anf__d16A)]}@@ -254,11 +254,11 @@                                   (VV#364 = lq_anf__d16z)]} bind 69 VV#367 : {VV#367 : int | [(VV#367 = 0)]} bind 70 VV#367 : {VV#367 : int | [(VV#367 = 0)]}-bind 71 VV#370 : {VV#370 : GHC.Types.Bool | [(Prop([VV#370]))]}-bind 72 VV#370 : {VV#370 : GHC.Types.Bool | [(Prop([VV#370]))]}-bind 73 VV#373 : {VV#373 : GHC.Types.Bool | [((Prop([VV#373])) <=> (gooberding#a15N >= lq_anf__d16x));+bind 71 VV#370 : {VV#370 : GHC.Types.Bool | [(? Prop([VV#370]))]}+bind 72 VV#370 : {VV#370 : GHC.Types.Bool | [(? Prop([VV#370]))]}+bind 73 VV#373 : {VV#373 : GHC.Types.Bool | [((? Prop([VV#373])) <=> (gooberding#a15N >= lq_anf__d16x));                                              (VV#373 = lq_anf__d16y)]}-bind 74 VV#373 : {VV#373 : GHC.Types.Bool | [((Prop([VV#373])) <=> (gooberding#a15N >= lq_anf__d16x));+bind 74 VV#373 : {VV#373 : GHC.Types.Bool | [((? Prop([VV#373])) <=> (gooberding#a15N >= lq_anf__d16x));                                              (VV#373 = lq_anf__d16y)]} bind 75 VV : {VV : a_a164 | [(VV = lq_anf__d16w);                              (VV = lq_anf__d16x)]}@@ -417,7 +417,7 @@        15;        31;        47]-  lhs {VV#F3 : GHC.Types.Bool | [(~ ((Prop([VV#F3]))));+  lhs {VV#F3 : GHC.Types.Bool | [(~ ((? Prop([VV#F3]))));                                  (VV#F3 = GHC.Types.False#68)]}   rhs {VV#F3 : GHC.Types.Bool | [$k_288[VV#287:=VV#F3][VV#349:=VV#F3][VV#F:=VV#F3]]}   id 3 tag [3]@@ -603,7 +603,7 @@        30;        15;        31]-  lhs {VV#F7 : GHC.Types.Bool | [(Prop([VV#F7]))]}+  lhs {VV#F7 : GHC.Types.Bool | [(? Prop([VV#F7]))]}   rhs {VV#F7 : GHC.Types.Bool | [$k_239[VV#238:=VV#F7][VV#370:=VV#F7][VV#F:=VV#F7]]}   id 7 tag [1] @@ -653,9 +653,9 @@        30;        15;        31]-  lhs {VV#F8 : GHC.Types.Bool | [((Prop([VV#F8])) <=> (gooberding#a15N >= lq_anf__d16x));+  lhs {VV#F8 : GHC.Types.Bool | [((? Prop([VV#F8])) <=> (gooberding#a15N >= lq_anf__d16x));                                  (VV#F8 = lq_anf__d16y)]}-  rhs {VV#F8 : GHC.Types.Bool | [(Prop([VV#F8]))]}+  rhs {VV#F8 : GHC.Types.Bool | [(? Prop([VV#F8]))]}   id 8 tag [1]
tests/pos/test000.hs.fq view
@@ -1,51 +1,51 @@-qualif Fst(v : @(1), y : @(0)) { v = fst([y])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.spec" (line 29, column 8)-qualif Snd(v : @(1), y : @(0)) { v = snd([y])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.spec" (line 30, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { (Prop([v])) <=> (len([xs]) > 0)  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 13, column 8)-qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]) { (Prop([v])) <=> (len([xs]) = 0)  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 14, column 8)-qualif ListZ(v : [@(0)]) { len([v]) = 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 16, column 8)-qualif ListZ(v : [@(0)]) { len([v]) >= 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 17, column 8)-qualif ListZ(v : [@(0)]) { len([v]) > 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 18, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) = len([xs])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 20, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) >= len([xs])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 21, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) > len([xs])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 22, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) <= len([xs])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 23, column 8)-qualif CmpLen(v : [@(1)], xs : [@(0)]) { len([v]) < len([xs])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 24, column 8)-qualif EqLen(v : int, xs : [@(0)]) { v = len([xs])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 26, column 8)-qualif LenEq(v : [@(0)], x : int) { x = len([v])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 27, column 8)-qualif LenDiff(v : [@(0)], x : int) { len([v]) = (x + 1)  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 28, column 8)-qualif LenDiff(v : [@(0)], x : int) { len([v]) = (x - 1)  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 29, column 8)-qualif LenAcc(v : int, xs : [@(0)], n : int) { v = (len([xs]) + n)  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 30, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 3, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 4, column 8)-qualif Bot(v : @(0)) { 0 = 1  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 5, column 8)-qualif Bot(v : bool) { 0 = 1  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 6, column 8)-qualif Bot(v : int) { 0 = 1  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 7, column 8)-qualif CmpZ(v : @(0)) { v < 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 9, column 8)-qualif CmpZ(v : @(0)) { v <= 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 10, column 8)-qualif CmpZ(v : @(0)) { v > 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 11, column 8)-qualif CmpZ(v : @(0)) { v >= 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 12, column 8)-qualif CmpZ(v : @(0)) { v = 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 13, column 8)-qualif CmpZ(v : @(0)) { v != 0  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 14, column 8)-qualif Cmp(v : @(0), x : @(0)) { v < x  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 16, column 8)-qualif Cmp(v : @(0), x : @(0)) { v <= x  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 17, column 8)-qualif Cmp(v : @(0), x : @(0)) { v > x  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 18, column 8)-qualif Cmp(v : @(0), x : @(0)) { v >= x  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 19, column 8)-qualif Cmp(v : @(0), x : @(0)) { v = x  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 20, column 8)-qualif Cmp(v : @(0), x : @(0)) { v != x  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 21, column 8)-qualif One(v : int) { v = 1  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 28, column 8)-qualif True(v : bool) { v  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 29, column 8)-qualif False(v : bool) { ~ ((v))  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 30, column 8)-qualif True1(v : GHC.Types.Bool) { Prop([v])  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 31, column 8)-qualif False1(v : GHC.Types.Bool) { ~ ((Prop([v])))  } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 32, column 8)-qualif Papp(v : @(0), p : (Pred  @(0))) { (papp1([p;-                                                   v])) } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 35, column 8)-qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))) { (papp2([p;+qualif Fst(v : @(1), y : @(0)): (v = fst([y])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.spec" (line 29, column 8)+qualif Snd(v : @(1), y : @(0)): (v = snd([y])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.spec" (line 30, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((? Prop([v])) <=> (len([xs]) > 0)) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 13, column 8)+qualif IsEmp(v : GHC.Types.Bool, xs : [@(0)]): ((? Prop([v])) <=> (len([xs]) = 0)) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 14, column 8)+qualif ListZ(v : [@(0)]): (len([v]) = 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 16, column 8)+qualif ListZ(v : [@(0)]): (len([v]) >= 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 17, column 8)+qualif ListZ(v : [@(0)]): (len([v]) > 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 18, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) = len([xs])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 20, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) >= len([xs])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 21, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) > len([xs])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 22, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) <= len([xs])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 23, column 8)+qualif CmpLen(v : [@(1)], xs : [@(0)]): (len([v]) < len([xs])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 24, column 8)+qualif EqLen(v : int, xs : [@(0)]): (v = len([xs])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 26, column 8)+qualif LenEq(v : [@(0)], x : int): (x = len([v])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 27, column 8)+qualif LenDiff(v : [@(0)], x : int): (len([v]) = (x + 1)) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 28, column 8)+qualif LenDiff(v : [@(0)], x : int): (len([v]) = (x - 1)) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 29, column 8)+qualif LenAcc(v : int, xs : [@(0)], n : int): (v = (len([xs]) + n)) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/GHC/Base.hquals" (line 30, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 3, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 4, column 8)+qualif Bot(v : @(0)): (0 = 1) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 5, column 8)+qualif Bot(v : bool): (0 = 1) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 6, column 8)+qualif Bot(v : int): (0 = 1) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 7, column 8)+qualif CmpZ(v : @(0)): (v < 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 9, column 8)+qualif CmpZ(v : @(0)): (v <= 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 10, column 8)+qualif CmpZ(v : @(0)): (v > 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 11, column 8)+qualif CmpZ(v : @(0)): (v >= 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 12, column 8)+qualif CmpZ(v : @(0)): (v = 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 13, column 8)+qualif CmpZ(v : @(0)): (v != 0) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 14, column 8)+qualif Cmp(v : @(0), x : @(0)): (v < x) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 16, column 8)+qualif Cmp(v : @(0), x : @(0)): (v <= x) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 17, column 8)+qualif Cmp(v : @(0), x : @(0)): (v > x) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 18, column 8)+qualif Cmp(v : @(0), x : @(0)): (v >= x) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 19, column 8)+qualif Cmp(v : @(0), x : @(0)): (v = x) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 20, column 8)+qualif Cmp(v : @(0), x : @(0)): (v != x) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 21, column 8)+qualif One(v : int): (v = 1) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 28, column 8)+qualif True(v : bool): (? v) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 29, column 8)+qualif False(v : bool): (~ ((? v))) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 30, column 8)+qualif True1(v : GHC.Types.Bool): (? Prop([v])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 31, column 8)+qualif False1(v : GHC.Types.Bool): (~ ((? Prop([v])))) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 32, column 8)+qualif Papp(v : @(0), p : (Pred  @(0))): (? papp1([p;+                                                   v])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 35, column 8)+qualif Papp2(v : @(1), x : @(0), p : (Pred  @(1)  @(0))): (? papp2([p;                                                                     v;-                                                                    x])) } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 38, column 8)-qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))) { (papp3([p;+                                                                    x])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 38, column 8)+qualif Papp3(v : @(2), x : @(0), y : @(1), p : (Pred  @(2)  @(0)  @(1))): (? papp3([p;                                                                                     v;                                                                                     x;-                                                                                    y])) } // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 41, column 8)+                                                                                    y])) // "/Users/benjamin/UCSDrepos/liquidhaskell/include/Prelude.hquals" (line 41, column 8)   @@ -138,11 +138,11 @@ bind 4 GHC.Types.EQ$35$6U : {VV$35$180 : GHC.Types.Ordering | [(VV$35$180 = GHC.Types.EQ$35$6U)]} bind 5 GHC.Types.LT$35$6S : {VV$35$181 : GHC.Types.Ordering | [(VV$35$181 = GHC.Types.LT$35$6S)]} bind 6 GHC.Types.GT$35$6W : {VV$35$182 : GHC.Types.Ordering | [(VV$35$182 = GHC.Types.GT$35$6W)]}-bind 7 GHC.Types.True$35$6u : {v_4 : GHC.Types.Bool | [(Prop([v_4]))]}-bind 8 GHC.Types.False$35$68 : {v_5 : GHC.Types.Bool | [(~ ((Prop([v_5]))))]}-bind 9 GHC.Types.False$35$68 : {v_5 : GHC.Types.Bool | [(~ ((Prop([v_5]))))]}+bind 7 GHC.Types.True$35$6u : {v_4 : GHC.Types.Bool | [(? Prop([v_4]))]}+bind 8 GHC.Types.False$35$68 : {v_5 : GHC.Types.Bool | [(~ ((? Prop([v_5]))))]}+bind 9 GHC.Types.False$35$68 : {v_5 : GHC.Types.Bool | [(~ ((? Prop([v_5]))))]} bind 10 GHC.Types.$91$$93$$35$6m : {VV : func(1, [[@(0)]]) | []}-bind 11 GHC.Types.True$35$6u : {v_4 : GHC.Types.Bool | [(Prop([v_4]))]}+bind 11 GHC.Types.True$35$6u : {v_4 : GHC.Types.Bool | [(? Prop([v_4]))]} bind 12 GHC.Types.GT$35$6W : {VV$35$227 : GHC.Types.Ordering | [(cmp([VV$35$227]) = GHC.Types.GT$35$6W)]} bind 13 GHC.Types.LT$35$6S : {VV$35$228 : GHC.Types.Ordering | [(cmp([VV$35$228]) = GHC.Types.LT$35$6S)]} bind 14 GHC.Types.EQ$35$6U : {VV$35$229 : GHC.Types.Ordering | [(cmp([VV$35$229]) = GHC.Types.EQ$35$6U)]}@@ -154,29 +154,29 @@ bind 20 lq_anf__d12s : {lq_tmp_x_275 : GHC.Types.Bool | [(lq_tmp_x_275 = Test0.toss$35$rYP)]} bind 21 lq_anf__d12s : {lq_tmp_x_277 : GHC.Types.Bool | [(lq_tmp_x_277 = Test0.toss$35$rYP)]} bind 22 lq_anf__d12s : {lq_tmp_x_277 : GHC.Types.Bool | [(lq_tmp_x_277 = Test0.toss$35$rYP);-                                                         (~ ((Prop([lq_tmp_x_277]))));-                                                         (~ ((Prop([lq_tmp_x_277]))));-                                                         (~ ((Prop([lq_tmp_x_277]))))]}+                                                         (~ ((? Prop([lq_tmp_x_277]))));+                                                         (~ ((? Prop([lq_tmp_x_277]))));+                                                         (~ ((? Prop([lq_tmp_x_277]))))]} bind 23 lq_anf__d12s : {lq_tmp_x_283 : GHC.Types.Bool | [(lq_tmp_x_283 = Test0.toss$35$rYP)]} bind 24 lq_anf__d12s : {lq_tmp_x_283 : GHC.Types.Bool | [(lq_tmp_x_283 = Test0.toss$35$rYP);-                                                         (Prop([lq_tmp_x_283]));-                                                         (Prop([lq_tmp_x_283]));-                                                         (Prop([lq_tmp_x_283]))]}+                                                         (? Prop([lq_tmp_x_283]));+                                                         (? Prop([lq_tmp_x_283]));+                                                         (? Prop([lq_tmp_x_283]))]} bind 25 lq_anf__d12t : {lq_tmp_x_288 : GHC.Types.Bool | [(lq_tmp_x_288 = lq_anf__d12s)]} bind 26 lq_anf__d12t : {lq_tmp_x_290 : GHC.Types.Bool | [(lq_tmp_x_290 = lq_anf__d12s)]} bind 27 lq_anf__d12t : {lq_tmp_x_290 : GHC.Types.Bool | [(lq_tmp_x_290 = lq_anf__d12s);-                                                         (~ ((Prop([lq_tmp_x_290]))));-                                                         (~ ((Prop([lq_tmp_x_290]))));-                                                         (~ ((Prop([lq_tmp_x_290]))))]}+                                                         (~ ((? Prop([lq_tmp_x_290]))));+                                                         (~ ((? Prop([lq_tmp_x_290]))));+                                                         (~ ((? Prop([lq_tmp_x_290]))))]} bind 28 lq_anf__d12t : {lq_tmp_x_296 : GHC.Types.Bool | [(lq_tmp_x_296 = lq_anf__d12s)]} bind 29 lq_anf__d12t : {lq_tmp_x_296 : GHC.Types.Bool | [(lq_tmp_x_296 = lq_anf__d12s);-                                                         (Prop([lq_tmp_x_296]));-                                                         (Prop([lq_tmp_x_296]));-                                                         (Prop([lq_tmp_x_296]))]}+                                                         (? Prop([lq_tmp_x_296]));+                                                         (? Prop([lq_tmp_x_296]));+                                                         (? Prop([lq_tmp_x_296]))]} bind 30 Test0.prop_abs$35$r10h : {VV$35$272 : GHC.Types.Bool | [$k__273]} bind 31 x$35$a11A : {VV$35$307 : int | [$k__308]} bind 32 lq_anf__d12u : {lq_tmp_x_315 : int | [(lq_tmp_x_315 = (0  :  int))]}-bind 33 lq_anf__d12v : {lq_tmp_x_321 : GHC.Types.Bool | [((Prop([lq_tmp_x_321])) <=> (x$35$a11A > lq_anf__d12u))]}+bind 33 lq_anf__d12v : {lq_tmp_x_321 : GHC.Types.Bool | [((? Prop([lq_tmp_x_321])) <=> (x$35$a11A > lq_anf__d12u))]} bind 34 lq_anf__d12w : {lq_tmp_x_345 : int | [$k__343[lq_tmp_x_340:=lq_anf__d12v][VV$35$342:=lq_tmp_x_345][lq_tmp_x_341:=x$35$a11A]]} bind 35 lq_anf__d12x : {lq_tmp_x_350 : int | [(lq_tmp_x_350 = (1  :  int))]} bind 36 lq_anf__d12y : {lq_tmp_x_373 : int | [(lq_tmp_x_373 = (12  :  int))]}@@ -223,16 +223,16 @@ bind 77 VV$35$477 : {VV$35$477 : int | [(VV$35$477 = x$35$a11A)]} bind 78 VV$35$480 : {VV$35$480 : int | [(VV$35$480 = 0)]} bind 79 VV$35$480 : {VV$35$480 : int | [(VV$35$480 = 0)]}-bind 80 VV$35$483 : {VV$35$483 : GHC.Types.Bool | [(Prop([VV$35$483]))]}-bind 81 VV$35$483 : {VV$35$483 : GHC.Types.Bool | [(Prop([VV$35$483]))]}+bind 80 VV$35$483 : {VV$35$483 : GHC.Types.Bool | [(? Prop([VV$35$483]))]}+bind 81 VV$35$483 : {VV$35$483 : GHC.Types.Bool | [(? Prop([VV$35$483]))]} bind 82 VV$35$486 : {VV$35$486 : GHC.Types.Bool | [(VV$35$486 = lq_anf__d12t)]} bind 83 VV$35$486 : {VV$35$486 : GHC.Types.Bool | [(VV$35$486 = lq_anf__d12t)]} bind 84 VV$35$489 : {VV$35$489 : GHC.Types.Bool | [(VV$35$489 = GHC.Types.False$35$68)]} bind 85 VV$35$489 : {VV$35$489 : GHC.Types.Bool | [(VV$35$489 = GHC.Types.False$35$68)]} bind 86 VV$35$492 : {VV$35$492 : GHC.Types.Bool | [(VV$35$492 = GHC.Types.False$35$68)]} bind 87 VV$35$492 : {VV$35$492 : GHC.Types.Bool | [(VV$35$492 = GHC.Types.False$35$68)]}-bind 88 VV$35$495 : {VV$35$495 : GHC.Types.Bool | [((Prop([VV$35$495])) <=> (lq_anf__d12q > lq_anf__d12r))]}-bind 89 VV$35$495 : {VV$35$495 : GHC.Types.Bool | [((Prop([VV$35$495])) <=> (lq_anf__d12q > lq_anf__d12r))]}+bind 88 VV$35$495 : {VV$35$495 : GHC.Types.Bool | [((? Prop([VV$35$495])) <=> (lq_anf__d12q > lq_anf__d12r))]}+bind 89 VV$35$495 : {VV$35$495 : GHC.Types.Bool | [((? Prop([VV$35$495])) <=> (lq_anf__d12q > lq_anf__d12r))]} bind 90 VV$35$498 : {VV$35$498 : int | [(VV$35$498 = lq_anf__d12r)]} bind 91 VV$35$498 : {VV$35$498 : int | [(VV$35$498 = lq_anf__d12r)]} bind 92 VV$35$501 : {VV$35$501 : int | [(VV$35$501 = lq_anf__d12q)]}@@ -309,7 +309,7 @@        15;        31]   lhs {VV$35$F8 : GHC.Types.Bool | [(VV$35$F8 = lq_anf__d12v)]}-  rhs {VV$35$F8 : GHC.Types.Bool | [(Prop([VV$35$F8]))]}+  rhs {VV$35$F8 : GHC.Types.Bool | [(? Prop([VV$35$F8]))]}   id 8 tag [3]   // META constraint id 8 : tests/pos/test000.hs:14:23-29 @@ -339,7 +339,7 @@        29;        14;        15]-  lhs {VV$35$F11 : GHC.Types.Bool | [(Prop([VV$35$F11]))]}+  lhs {VV$35$F11 : GHC.Types.Bool | [(? Prop([VV$35$F11]))]}   rhs {VV$35$F11 : GHC.Types.Bool | [$k__273[VV$35$272:=VV$35$F11][VV$35$F:=VV$35$F11][VV$35$483:=VV$35$F11]]}   id 11 tag [6]   // META constraint id 11 : tests/pos/test000.hs:10:33-50@@ -371,7 +371,7 @@        14;        15]   lhs {VV$35$F12 : GHC.Types.Bool | [(VV$35$F12 = lq_anf__d12t)]}-  rhs {VV$35$F12 : GHC.Types.Bool | [(Prop([VV$35$F12]))]}+  rhs {VV$35$F12 : GHC.Types.Bool | [(? Prop([VV$35$F12]))]}   id 12 tag [6]   // META constraint id 12 : tests/pos/test000.hs:10:47-50 @@ -456,7 +456,7 @@        13;        14;        15]-  lhs {VV$35$F15 : GHC.Types.Bool | [((Prop([VV$35$F15])) <=> (lq_anf__d12q > lq_anf__d12r))]}+  lhs {VV$35$F15 : GHC.Types.Bool | [((? Prop([VV$35$F15])) <=> (lq_anf__d12q > lq_anf__d12r))]}   rhs {VV$35$F15 : GHC.Types.Bool | [$k__235[VV$35$F:=VV$35$F15][VV$35$495:=VV$35$F15][VV$35$234:=VV$35$F15]]}   id 15 tag [5]   // META constraint id 15 : tests/pos/test000.hs:6:1-22
tests/pos/test00a.fq view
@@ -1,5 +1,5 @@ // This qualifier saves the day; solve constraints WITHOUT IT-qualif Zog(v:a)  { 10 <= v }+qualif Zog(v:a) : (10 <= v)  bind 0 x : {v : int | true} bind 1 y : {v : int | true}
tests/pos/test1.fq view
@@ -1,6 +1,6 @@  // This qualifier saves the day; solve constraints WITHOUT IT-qualif Zog(v:a)  { 10 <= v }+qualif Zog(v:a) : (10 <= v)  bind 0 x : {v : int | v = 10} bind 1 y : {v : int | v = 20}
tests/pos/test2.fq view
@@ -1,9 +1,9 @@  // This qualifier saves the day; solve constraints WITHOUT IT-qualif Zog(v:a) { 10 <= v }+qualif Zog(v:a): (10 <= v)  // But you may use this one-qualif Pog(v:a) { 0 <= v }+qualif Pog(v:a): (0 <= v)  bind 0 x: {v: int | v = 10} bind 1 a: {v: int | $k1    }
tests/pos/test3.fq view
@@ -1,5 +1,5 @@ -qualif Zog(v:a, z:b)  { v = z }+qualif Zog(v:a, z:b) : (v = z)  bind 0 x : {v : int | true} bind 1 q : {v : int | true}
tests/pos/test4.fq view
@@ -1,4 +1,4 @@-qualif Auto(v_2 : a_ax6, A0 : a_ax6) { v_2 = A0 }+qualif Auto(v_2 : a_ax6, A0 : a_ax6): (v_2 = A0)  bind 20 ds_dxx : {VV263 : a_ax6 | []}
tests/pos/unexpected-ge.fq view
@@ -1,2 +1,2 @@ -qualif Auto(v : int, x : int) { v = (if (x > 0) then 0 else 0) }+qualif Auto(v : int, x : int): (v = (if (x > 0) then 0 else 0))
tests/pos/wl00.fq view
@@ -1,6 +1,6 @@-qualif Nat(v:int)  { 0 <= v }-qualif N10(v:int)  { 10 = v }-qualif N20(v:int)  { 20 = v }+qualif Nat(v:int) : (0 <= v)+qualif N10(v:int) : (10 = v)+qualif N20(v:int) : (20 = v)  bind 0 x0 : {v: int | [$k0]}
tests/pos/wl01.fq view
@@ -1,4 +1,4 @@-qualif Nat(v:int)  { 0 <= v }+qualif Nat(v:int) : (0 <= v)  bind 0 x : {v: int | [$k0]} bind 1 y : {v: int | [$k0]}
tests/pos/wl02.fq view
@@ -1,4 +1,4 @@-qualif Nat(v:int)  { 0 <= v }+qualif Nat(v:int) : (0 <= v)  bind 0  x0  : {v: int | [$k0]} bind 1  x1  : {v: int | [$k1]}
+ 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/Arbitrary.hs 
@@ -1,378 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}--{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module Arbitrary-  ( subexprs-  , Env(..)-  , NoAnfEnv(..)-  , AnfSymbol(..)-  , FlatAnfEnv(..)-  , ChainedAnfEnv(..)-  ) where--import qualified Data.Text                 as Text-import qualified Data.HashMap.Strict       as M-import Test.Tasty.QuickCheck-import GHC.Generics--import Language.Fixpoint.Types.Refinements as R-import Language.Fixpoint.Parse             (isNotReserved)-import Language.Fixpoint.Types             as T hiding (Result)-import Data.Traversable                    (for)--{----- An example of how the Arbitrary Expr instance can be used.--- Note that `expr == rr (showpp expr)` is *not* something we expect to hold.--- See https://github.com/ucsd-progsys/liquid-fixpoint/issues/46--quickCheckTests :: TestTree-quickCheckTests-  = testGroup "Properties"-      [ testProperty "prop_pprint_parse_inv_expr" prop_pprint_parse_inv_expr-      ]--prop_pprint_parse_inv_expr :: Expr -> Bool-prop_pprint_parse_inv_expr expr = expr == rr (showpp expr)---}---- NOTE: `shrink _ = mempty` is identical to the default (implicit) shrink implementation.--- We prefer to make it explicit.--instance Arbitrary Expr where-  arbitrary = sized arbitraryExpr-  shrink x = filter valid $ genericShrink x-    where-      valid e@(T.PAnd es)     = length es >= 2 && all valid (subexprs e)-      valid e@(T.POr es)      = length es >= 2 && all valid (subexprs e)-      valid e@(T.PAll es _)   = length es >= 2 && all valid (subexprs e)-      valid e@(T.PExist es _) = length es >= 2 && all valid (subexprs e)-      valid e                 = all valid (subexprs e)--subexprs :: Expr -> [Expr]-subexprs (ESym _)        = []-subexprs (ECon _)        = []-subexprs (EVar _)        = []-subexprs (EApp e0 e1)    = [e0, e1]-subexprs (ENeg e)        = [e]-subexprs (EBin _ e0 e1)  = [e0, e1]-subexprs (EIte e0 e1 e2) = [e0, e1, e2]-subexprs (ECst e _)      = [e]-subexprs (ELam _ e)      = [e]-subexprs (ETApp e _)     = [e]-subexprs (ETAbs e _)     = [e]-subexprs (T.PAnd es)     = es-subexprs (T.POr es)      = es-subexprs (T.PNot e)      = [e]-subexprs (PImp e0 e1)    = [e0, e1]-subexprs (PIff e0 e1)    = [e0, e1]-subexprs (PAtom _ e0 e1) = [e0, e1]-subexprs (PKVar _ _ _)   = []-subexprs (PAll _ e)      = [e]-subexprs (PExist _ e)    = [e]-subexprs (ECoerc _ _ e)  = [e]-subexprs (ELet _ e1 e2)  = [e1, e2]---- TODO: Adjust frequencies--- | To ensure this reliably terminates we require that `zeroExprGen` generates--- atomic expressions.-arbitraryFiniteExpr-  :: Gen Expr -- ^ called when the Int is zero.-  -> Int-  -> Gen Expr-arbitraryFiniteExpr zeroExprGen 0 = zeroExprGen-arbitraryFiniteExpr zeroExprGen n = frequency-  [ (1, EApp <$> arbitraryExpr' <*> arbitraryExpr')-  , (1, ENeg <$> arbitraryExpr')-  , (1, EBin <$> arbitrary <*> arbitraryExpr' <*> arbitraryExpr')-  , (1, EIte <$> arbitraryExpr' <*> arbitraryExpr' <*> arbitraryExpr')-  , (1, ECst <$> arbitraryExpr' <*> arbitrary)-  , (1, ELam <$> arbitrary <*> arbitraryExpr')-  , (1, ETApp <$> arbitraryExpr' <*> arbitrary)-  , (1, ETAbs <$> arbitraryExpr' <*> arbitrary)-  , (1, T.PAnd <$> arbitraryExprList)-  , (1, T.POr <$> arbitraryExprList)-  , (1, T.PNot <$> arbitraryExpr')-  , (1, PImp <$> arbitraryExpr' <*> arbitraryExpr')-  , (1, PIff <$> arbitraryExpr' <*> arbitraryExpr')-  , (1, PAtom <$> arbitrary <*> arbitraryExpr' <*> arbitraryExpr')-  , (1, PKVar <$> arbitrary <*> pure mempty <*> arbitrary)-  , (1, PAll <$> arbitraryList arbitrary <*> arbitraryExpr')-  , (1, PExist <$> arbitraryList arbitrary <*> arbitraryExpr')-  , (1, ECoerc <$> arbitrary <*> arbitrary <*> arbitraryExpr')-  , (1, ELet <$> arbitrary <*> arbitraryExpr' <*> arbitraryExpr')-  ]-  where-    arbitraryExpr' = arbitraryFiniteExpr zeroExprGen (n `div` 2)-    arbitraryList :: Gen a -> Gen [a]-    arbitraryList gen = choose (2, 3) >>= (`vectorOf` gen)-    arbitraryExprList = arbitraryList arbitraryExpr'---- | Generates a finite expression, with the logarithm of the Int given--- suggesting the depth of the expression tree.-arbitraryExpr :: Int -> Gen Expr-arbitraryExpr = arbitraryFiniteExpr arbitraryAtomicExpr--arbitraryAtomicExpr :: Gen Expr-arbitraryAtomicExpr = oneof [ESym <$> arbitrary, ECon <$> arbitrary, EVar <$> arbitrary]--arbitraryEqualityConstraint :: Gen Brel-arbitraryEqualityConstraint = oneof [pure Eq, pure Ueq]---- | Generates an expression that involves the given Symbol in an Eq or Ueq--- PAtom with an arbitrary non-lq_anf$ EVar.-arbitraryExprInvolving :: Symbol -> Int -> Gen Expr-arbitraryExprInvolving sym = arbitraryFiniteExpr . pure $ EVar sym--instance Arbitrary KVar where-  arbitrary = KV <$> arbitrary--instance Arbitrary Subst where-  arbitrary = do-    n <- choose (0, 3)-    l <- vectorOf n arbitrary-    return $ Su $ M.fromList l-  shrink _ = mempty--instance Arbitrary (KVarSubst Symbol Symbol) where-  arbitrary = do-    n <- choose (0, 3)-    l <- vectorOf n arbitrary-    return $ toKVarSubst $ M.fromList l--instance Arbitrary (M.HashMap Symbol Sort) where-  arbitrary = M.fromList <$> arbitrary-  shrink = map M.fromList . shrink . M.toList---- | This instance only creates `FVar` when they would be in scope from an--- enclosing `FAbs`, and does not create `FObj`s-instance Arbitrary Sort where-  arbitrary = sized arbitrarySort-  shrink = genericShrink---- | Create an arbitrary well-formed sort that does not contain `FObj`s.------ The sort is \"well-formed\" in the sense that all `FVar`s have an enclosing--- `FAbs` bringing them into scope.-arbitrarySort :: Int -> Gen Sort-arbitrarySort = arbitrarySortPossiblyInvolving []---- | Create an arbitrary sort, possibly involving the variables represented by--- the list of Ints. Can possibly create a `FAbs` that will also possibly--- reference the new variable in an `FVar`, even when the first argument is--- [].-arbitrarySortPossiblyInvolving :: [Int] -> Int -> Gen Sort-arbitrarySortPossiblyInvolving [] n = frequency-  [ (4, arbitrarySortNoAbs n)-  , (1, newAbs [] n) ]-arbitrarySortPossiblyInvolving vars n = do-  let fvar = oneof $ pure . FVar <$> vars-  frequency-    [ (1, arbitrarySortNoAbs n)-    , (1, FFunc <$> fvar <*> arbitrarySortPossiblyInvolving vars (n `div` 2))-    , (1, FFunc <$> arbitrarySortPossiblyInvolving vars (n `div` 2) <*> fvar)-    , (1, FApp <$> fvar <*> arbitrarySortPossiblyInvolving vars (n `div` 2))-    , (1, FApp <$> arbitrarySortPossiblyInvolving vars (n `div` 2) <*> fvar)-    , (1, fvar)-    , (1, newAbs vars n)-    ]---- | Create a new FAbs sort whose body might involve the newly created variable.--- First argument is the variables already in scope.-newAbs :: [Int] -> Int -> Gen Sort-newAbs vars n = do-  v <- arbitrary-  if v `elem` vars-    then discard v-    else FAbs v <$> arbitrarySortPossiblyInvolving (v:vars) (n `div` 2)---- | Does not create FObj, FAbs, or FVar-arbitrarySortNoAbs :: Int -> Gen Sort-arbitrarySortNoAbs 0 = oneof (pure <$> [FInt, FReal, FNum, FFrac])-arbitrarySortNoAbs n = frequency-  [ (1, FFunc <$> arbitrarySortNoAbs' <*> arbitrarySortNoAbs')-  , (1, FTC <$> arbitrary)-  , (1, FApp <$> arbitrarySortNoAbs' <*> arbitrarySortNoAbs')-  ]-  where-    arbitrarySortNoAbs' = arbitrarySortNoAbs (n `div` 2)--instance Arbitrary Brel where-  arbitrary = oneof (map return [Eq, Ne, Gt, Ge, Lt, Le, Ueq, Une])-  shrink _ = mempty--instance Arbitrary Bop where-  arbitrary = oneof (map return [Plus, Minus, Times, Div, Mod])-  shrink _ = mempty--instance Arbitrary SymConst where-  arbitrary = SL . unShortLowercaseAlphabeticText <$> arbitrary---- | Note that we rely below on the property that the Arbitrary instance for--- Symbol cannot create lq_anf$ vars.-instance Arbitrary Symbol where-  arbitrary = (symbol :: Text.Text -> Symbol) . unShortLowercaseAlphabeticText <$> arbitrary-  shrink _ = mempty--newtype ShortLowercaseAlphabeticText = ShortLowercaseAlphabeticText { unShortLowercaseAlphabeticText :: Text.Text }-  deriving (Eq, Show, Generic)--instance Arbitrary ShortLowercaseAlphabeticText where-  arbitrary = ShortLowercaseAlphabeticText <$> (choose (5, 12) >>= \n -> Text.pack <$> (vectorOf n char `suchThat` valid))-    where-      char = elements ['a'..'z']-      valid x = isNotReserved x && not (isFixKey (Text.pack x))-  shrink _ = mempty--instance Arbitrary FTycon where-  arbitrary = do-    c <- elements ['A'..'Z']-    t <- unShortLowercaseAlphabeticText <$> arbitrary-    return $ symbolFTycon $ dummyLoc $ symbol $ c `Text.cons` t-  shrink _ = mempty--instance Arbitrary Constant where-  arbitrary = oneof [ I <$> arbitrary `suchThat` (>= 0) -- Negative values use `ENeg`-                    , R <$> arbitrary `suchThat` (>= 0) -- Negative values use `ENeg`-                    , L . unShortLowercaseAlphabeticText <$> arbitrary <*> arbitrary-                    ]-  shrink (I x) = I <$> shrink x-  shrink (R x) = R <$> shrink x-  shrink (L x y) = L x <$> shrink y---- | Used in UndoANFTests.-newtype AnfSymbol = AnfSymbol { unAnfSymbol :: Symbol }-  deriving (Eq, Show, Generic)-instance Arbitrary AnfSymbol where-  arbitrary = AnfSymbol . mappendSym anfPrefix <$> arbitrary-  shrink = mempty---- | This instance does **not** create Refts with anf symbols.-instance Arbitrary Reft where-  arbitrary = reft <$> arbitrary <*> arbitrary-  shrink = genericShrink---- | This instance does **not** create SortedRefts with anf symbols.-instance Arbitrary SortedReft where-  arbitrary = sized $ arbitrarySortedReft (const arbitrary) (const arbitrary)-  shrink = genericShrink--arbitrarySortedReft :: (Int -> Gen Sort) -> (Int -> Gen Symbol) -> Int -> Gen SortedReft-arbitrarySortedReft sortGen symGen n = do-  sort <- sortGen n-  eq <- arbitraryEqualityConstraint-  sym <- symGen n-  RR sort . reft sym . PAtom eq (EVar sym) <$> arbitrary--newtype IntSortedReft = IntSortedReft { unIntSortedReft :: SortedReft }-  deriving (Eq, Show)--instance Arbitrary IntSortedReft where-  arbitrary = sized $ fmap IntSortedReft . arbitrarySortedReft (const . pure $ FInt) (const arbitrary)---- | Base environment with no declared properties; do not add an Arbitrary--- instance to this and instead use newtypes.-newtype Env = Env { unEnv :: [(Symbol, SortedReft)] }-  deriving (Eq, Show, Generic)--shrinkEnv :: Env -> [Env]-shrinkEnv = fmap Env . traverse (traverse shrink) . unEnv---- | Env without anf vars.-newtype NoAnfEnv = NoAnfEnv { unNoAnfEnv :: Env }-  deriving (Eq, Show, Generic)-instance Arbitrary NoAnfEnv where-  arbitrary = sized (fmap NoAnfEnv . arbitraryEnv gen)-    where-      -- | Note that this relies on the property that the Arbitrary instance for-      -- Symbol cannot create lq_anf$ vars.-      gen n = vectorOf n ((\a b -> (a, unIntSortedReft b)) <$> arbitrary <*> arbitrary)-  shrink = fmap NoAnfEnv . shrinkEnv . unNoAnfEnv---- | Env with anf vars that do not reference further anf vars.-newtype FlatAnfEnv = FlatAnfEnv { unFlatAnfEnv :: Env }-  deriving (Eq, Show, Generic)-instance Arbitrary FlatAnfEnv where-  arbitrary = sized (fmap FlatAnfEnv . arbitraryEnv gen)-    where-      anfsGen n = vectorOf n ((\a b -> (unAnfSymbol a, unIntSortedReft b)) <$> arbitrary <*> arbitrary)-      gen = finalAnfGen anfsGen finalFlatGen-      finalFlatGen :: [(Symbol, SortedReft)] -> Gen (Symbol, SortedReft)-      -- This creates a final symbol which is either the conjunction or-      -- disjunction of all the anf symbols.-      finalFlatGen anfs = do-        conjOrDisj <- oneof $ pure <$> [T.PAnd, T.POr]-        let ultimateAnfExpr = conjOrDisj $ EVar . fst <$> anfs-        sym <- arbitrary-        ultimateAnfSym <- arbitrary-        pure (sym, RR FInt (reft ultimateAnfSym (PAtom Eq (EVar ultimateAnfSym) ultimateAnfExpr)))-  -- TODO-  shrink (FlatAnfEnv (Env (_x : xs))) = pure . FlatAnfEnv . Env $ xs-  shrink _ = mempty---- | Given a generator for a bunch of (`Symbol`, `SortedReft`) pairs which bind--- lq_anf$ vars, and another generator that takes those pairs and binds a--- non-lq_anf$ var to some subset of them, this function generates those pairs--- plus the \"final\" non-lq_anf$ expression, which represents the \"original\"--- expression brought to ANF.-finalAnfGen :: (Int -> Gen [(Symbol, SortedReft)]) -> ([(Symbol, SortedReft)] -> Gen (Symbol, SortedReft)) -> Int -> Gen [(Symbol, SortedReft)]-finalAnfGen anfsGen finalGen n = do-  anfs <- anfsGen n-  ultimateAnf <- finalGen anfs-  pure $ ultimateAnf : anfs---- | Create an arbitrary env up to size k with the given generator for Symbols--- and SortedRefts-arbitraryEnv :: (Int -> Gen [(Symbol, SortedReft)]) -> Int -> Gen Env--arbitraryEnv gen k = Env <$> (choose (0, k) >>= gen)---- | Env with anf vars that form a list of references.-newtype ChainedAnfEnv = ChainedAnfEnv { unChainedAnfEnv :: Env }-  deriving (Eq, Show, Generic)-instance Arbitrary ChainedAnfEnv where-  arbitrary = sized (fmap ChainedAnfEnv . arbitraryEnv gen)-    where-      gen = finalAnfGen (chainedAnfGen anfSymNGen) finalChainedGen-      finalChainedGen :: [(Symbol, SortedReft)] -> Gen (Symbol, SortedReft)-      finalChainedGen anfs =-        case anfs of-          -- No ANFs, so just an arbitrary int sorted expression will do-          [] -> fmap unIntSortedReft <$> arbitrary-          ((penultimateSym, _):_) -> do-            sym <- arbitrary-            let sreft = RR FInt (reft sym (PAtom Eq (EVar sym) (EVar penultimateSym)))-            (, sreft) <$> arbitrary-  -- TODO-  shrink (ChainedAnfEnv (Env (_x : xs))) = pure . ChainedAnfEnv . Env $ xs-  shrink _ = mempty---- | Creates a "chain" of referencing `lq_anf$` var Symbols of length `n` such--- that the first symbol references the second which references the third, and--- so on.  The last symbol is bound to an arbitrary non-lq_anf$ var.------ This list is in an acceptable form to be passed to `finalAnfGen` to close the--- loop.-chainedAnfGen :: (Int -> Gen AnfSymbol) -> Int -> Gen [(Symbol, SortedReft)]-chainedAnfGen _ 0 = pure []-chainedAnfGen symGen n = do-  syms <- fmap unAnfSymbol <$> for [1..n+1] symGen-  finalSym <- arbitrary-  let symPairs :: [(Symbol, Symbol)]-      symPairs = pairs (syms ++ [finalSym])-  for symPairs $ \(sym, prevSym) -> do-    otherSym <- arbitrary-    prevSymExpr <- arbitraryExprInvolving prevSym n-    pure (sym, RR FInt (reft otherSym (PAtom Eq (EVar otherSym) prevSymExpr)))-  where-    pairs xs = zip xs (drop 1 xs)---- This is not random, but is simplified so that you can make chains more--- easily.-anfSymNGen :: Int -> Gen AnfSymbol-anfSymNGen i = pure . AnfSymbol . mappendSym anfPrefix . symbol . show $ i
− tests/tasty/InterpretTests.hs 
@@ -1,33 +0,0 @@-module InterpretTests (tests) where--import Arbitrary ()-import Language.Fixpoint.Types.Refinements (Expr)-import qualified SimplifyInterpreter-import Test.Tasty-  ( TestTree,-    adjustOption,-    testGroup,-  )-import Test.Tasty.QuickCheck-  ( Property,-    QuickCheckMaxSize (..),-    QuickCheckTests (..),-    testProperty,-    (===),-  )--tests :: TestTree-tests =-  withOptions $-    testGroup-      "interpret"-      [ testProperty "computes a fixpoint" (prop_fixpoint SimplifyInterpreter.interpret')-      ]-  where-    withOptions tests' =-      adjustOption (\(QuickCheckMaxSize n) -> QuickCheckMaxSize (div n 4)) $-      adjustOption (\(QuickCheckTests n) -> QuickCheckTests (n * 20))-      tests'--prop_fixpoint :: (Expr -> Expr) -> Expr -> Property-prop_fixpoint f e = f e === f (f e)
tests/tasty/Main.hs view
@@ -4,18 +4,11 @@  import qualified ParserTests import qualified ShareMapTests-import qualified SimplifyTests-import qualified SimplifyKVarTests-import qualified InterpretTests-import qualified UndoANFTests import Test.Tasty+import Test.Tasty.HUnit  main :: IO () main = defaultMain $ testGroup "Tests"   [ ParserTests.tests   , ShareMapTests.tests-  , SimplifyTests.tests-  , SimplifyKVarTests.tests-  , InterpretTests.tests-  , UndoANFTests.tests   ]
tests/tasty/ParserTests.hs view
@@ -2,7 +2,7 @@  module ParserTests (tests) where -import Language.Fixpoint.Types (showpp, showFix)+import Language.Fixpoint.Types (showFix) import Language.Fixpoint.Parse import Test.Tasty import Test.Tasty.HUnit@@ -131,7 +131,11 @@ testFunAppP :: TestTree testFunAppP =   testGroup "FunAppP"-    [ testCase "ECon (exprFunSpacesP)" $+    [ 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)" $@@ -196,14 +200,54 @@         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 "exprP"-    [ testCase "ECon (litP)" $-        show (doParse' exprP "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 "PTrue" $+  testGroup "predP"+    [ testCase "PTrue" $         show (doParse' predP "test" "true") @?= "PAnd []" -- pattern for PTrue      , testCase "PFalse" $@@ -214,20 +258,18 @@    --   "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\" (fromList []) "+        show (doParse' predP "test" "$foo") @?= "PKVar $\"foo\" "      , testCase "kvarPred one" $-        show (doParse' predP "test" "$foo  [x := 1]") @?= "PKVar $\"foo\" (fromList []) [x:=1]"+        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\" (fromList []) [x:=1][y:=true]"--    , testCase "kvarPred tyvar subst" $-        showpp (doParse' predP "test" "$foo[@a:=b;c:=d] [x := 1] [ y := true ]") @?= "$foo[@a:=b;c:=d][x:=1][y:=true]"+        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" ) @?=-          "EIte (PAnd []) (PAnd []) (POr [])"+          -- 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))"@@ -235,6 +277,9 @@     , 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\")" @@ -244,12 +289,6 @@     , testCase "funApp 3" $         show (doParse' predP "test" "f ([a; b])") @?= "EApp (EApp (EVar \"f\") (EVar \"a\")) (EVar \"b\")" -    , testCase "funApp 4" $-        show (doParse' funAppP "" "f (x > 1)") @?= "EApp (EVar \"f\") (PAtom Gt (EVar \"x\") (ECon (I 1)))"--    , testCase "funApp 5" $-        show (doParse' predP "" "f (x > 1)") @?= "EApp (EVar \"f\") (PAtom Gt (EVar \"x\") (ECon (I 1)))"-     , testCase "symbol" $         show (doParse' predP "test" "f") @?= "EVar \"f\"" @@ -257,7 +296,7 @@         show (doParse' predP "test" "&& []") @?= "PAnd []"      , testCase "&& 1" $-        show (doParse' predP "test" "&& [x]") @?= "PAnd [EVar \"x\"]"+        show (doParse' predP "test" "&& [x]") @?= "EVar \"x\""      , testCase "&& 2" $         show (doParse' predP "test" "&& [x;y]") @?= "PAnd [EVar \"x\",EVar \"y\"]"
tests/tasty/ShareMapReference.hs view
@@ -71,14 +71,15 @@        | otherwise ->          let v0 = h HashMap.! k0              v1 = maybe v0 (f v0) $ HashMap.lookup k1 h-             (kHead, keys') = case break (HashSet.member k1) (before0 ++ after0) of+             keys'+               | otherwise = case break (HashSet.member k1) (before0 ++ after0) of                  (before1, []) ->-                    (HashSet.insert k1 keys0, before1)+                    HashSet.insert k1 keys0 : before1                  (before1, keys1 : after1)->-                    (HashSet.union keys0 keys1, before1 ++ after1)+                    HashSet.union keys0 keys1 : before1 ++ after1           in sm               { toHashMap =-                  HashSet.foldl' (\h' k' -> HashMap.insert k' v1 h') h kHead-              , keyPartitions = kHead : keys'+                  HashSet.foldl' (\h' k' -> HashMap.insert k' v1 h') h (head keys')+              , keyPartitions = keys'               } mergeKeysWith _ _ _ sm = sm
tests/tasty/ShareMapTests.hs view
@@ -1,18 +1,15 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}  module ShareMapTests where  import Data.HashMap.Lazy (HashMap)-#if MIN_VERSION_base(4,20,0)-import Data.List (nub)-#else+import qualified Data.HashMap.Lazy as HashMap import Data.List (foldl', nub)-#endif 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/tasty/SimplifyInterpreter.hs 
@@ -1,40 +0,0 @@-module SimplifyInterpreter (interpret', simplify') where--import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Language.Fixpoint.Solver.Interpreter (ICtx (..), Knowledge (..))-import qualified Language.Fixpoint.Solver.Interpreter as Interpreter-import Language.Fixpoint.Types.Environments (SEnvB (..))-import Language.Fixpoint.Types.Refinements (Expr)--interpret' :: Expr -> Expr-interpret' = Interpreter.interpret emptyConstMap emptyKnowledge emptyICtx emptySEnv-  where-    emptyConstMap = M.empty-    emptySEnv = SE M.empty--simplify' :: Expr -> Expr-simplify' = Interpreter.simplify emptyKnowledge emptyICtx--emptyKnowledge :: Interpreter.Knowledge-emptyKnowledge =-  Interpreter.KN-    { knSims = M.empty, -- :: M.HashMap (Symbol, Symbol) Rewrite-      knAms = M.empty, -- :: M.HashMap Symbol Equation-      knLams = [], -- :: ![(Symbol, Sort)]-      knSummary = [], -- :: ![(Symbol, Int)]-      knDCs = S.empty, -- :: !(S.HashSet Symbol)-      knAllDCs = S.empty, -- :: !(S.HashSet Symbol)-      knSels = M.empty, -- :: !SelectorMap-      knConsts = M.empty -- :: !ConstDCMap-    }--emptyICtx :: Interpreter.ICtx-emptyICtx =-  Interpreter.ICtx-    { icCands = S.empty, -- :: S.HashSet Expr-      icEquals = S.empty, -- :: EvAccum-      icSolved = S.empty, -- :: S.HashSet Expr-      icSimpl = M.empty, -- :: !ConstMap-      icSubcId = Nothing -- :: Maybe SubcId-    }
− tests/tasty/SimplifyPLE.hs 
@@ -1,47 +0,0 @@-module SimplifyPLE (simplify') where--import qualified Data.HashMap.Strict as SM-import qualified Data.HashSet as S-import qualified Data.Map as M-import Language.Fixpoint.Solver.PLE (ICtx (..), Knowledge (..))-import qualified Language.Fixpoint.Solver.PLE as PLE-import Language.Fixpoint.Types.Refinements (Expr)--simplify' :: Expr -> Expr-simplify' = PLE.simplify emptyKnowledge emptyICtx-  where-    emptyKnowledge :: PLE.Knowledge-    emptyKnowledge =-      -- @PLE.simplify@ does not actually use all these fields, so we can get-      -- away with leaving some of them @undefined@.-      KN-        { knSims = M.empty, -- :: Map Symbol [(Rewrite, IsUserDataSMeasure)]-          knAms = M.empty, -- :: Map Symbol Equation-          knPreds = undefined, -- :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool-          knLams = [], -- :: ![(Symbol, Sort)]-          knSummary = [], -- :: ![(Symbol, Int)]-          knDCs = S.empty, -- :: !(S.HashSet Symbol)-          knDataCtors = SM.empty, -- :: !(M.HashMap Symbol DataCtor)-          knSels = [], -- :: !SelectorMap-          knConsts = [], -- :: !ConstDCMap-          knAutoRWs = SM.empty, -- :: M.HashMap SubcId [AutoRewrite]-          knRWTerminationOpts = undefined -- :: RWTerminationOpts-        }--    emptyICtx :: PLE.ICtx-    emptyICtx =-      ICtx-        { icAssms = S.empty,      -- S.HashSet Pred-          icCands = mempty,      -- :: S.HashSet Expr-          icEquals = mempty,     -- :: EvAccum-          icSimpl = SM.empty,     -- :: !ConstMap-          icSubcId = Nothing,     -- :: Maybe SubcId-          icANFs = [],            -- :: [[(Symbol, SortedReft)]]-          icLRWs = mempty,-          icEtaBetaFlag        = False,-          icExtensionalityFlag = False,-          icLocalRewritesFlag  = False,-          icBindIds = mempty,-          icFreshExistentialCounter = 0,-          icInitialLHSs = mempty-        }
− tests/tasty/SimplifyTests.hs 
@@ -1,49 +0,0 @@-module SimplifyTests (tests) where--import Arbitrary (subexprs)-import Language.Fixpoint.Types.Refinements (Bop (Minus), Constant (I), Expr, ExprBV (..))-import qualified SimplifyInterpreter-import qualified SimplifyPLE-import Test.Tasty-  ( TestTree,-    localOption,-    testGroup,-  )-import Test.Tasty.QuickCheck-  ( Property,-    QuickCheckMaxSize (..),-    QuickCheckTests (..),-    counterexample,-    label,-    testProperty,-  )--tests :: TestTree-tests =-  withOptions $-    testGroup-      "simplify does not increase expression size"-      [ testProperty "PLE" (prop_no_increase SimplifyPLE.simplify'),-        testProperty "Interpreter" (prop_no_increase SimplifyInterpreter.simplify')-      ]-  where-    withOptions tests' = localOption (QuickCheckMaxSize 4) (localOption (QuickCheckTests 500) tests')--prop_no_increase :: (Expr -> Expr) -> Expr -> Property-prop_no_increase f e =-  let originalSize = exprSize e-      simplified = f e-      simplifiedSize = exprSize simplified-   in label ("reduced size by " ++ show (originalSize - simplifiedSize)) $-        counterexample-          ( unlines-              [ show simplifiedSize ++ " > " ++ show originalSize,-                "simplified: " ++ show simplified-              ]-          )-          (simplifiedSize <= originalSize)--exprSize :: Expr -> Int--- Undo the removal of ENeg in @simplify@ so it does not count as increasing the size of the expression.-exprSize (EBin Minus (ECon (I 0)) e) = exprSize (ENeg e)-exprSize e = 1 + sum (exprSize <$> subexprs e)
− tests/tasty/UndoANFTests.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module UndoANFTests(tests) where--import Language.Fixpoint.Types (SortedReft(..), Symbol,-                                isPrefixOfSym, anfPrefix, syms)-import Language.Fixpoint.Solver.EnvironmentReduction (undoANFSimplifyingWith)-import Arbitrary-import qualified Data.HashMap.Strict as M-import Test.Tasty (TestTree, testGroup, adjustOption)-import Test.Tasty.HUnit ((@?=))-import qualified Test.Tasty.HUnit as H-import Test.Tasty.QuickCheck ((===))-import qualified Test.Tasty.QuickCheck as Q---tests :: TestTree-tests =-  withOptions $-    testGroup-      "undoANFSimplifyingWith id id"-      [ H.testCase "id on empty env" $-          simpleUndoANF [] @?= M.empty-      , Q.testProperty "id when env contains no lq_anf$* bindings" $-          prop_no_change (M.fromList . unEnv . unNoAnfEnv) simpleUndoANFNoAnfEnv-      , testGroup-          "zero anf vars left afterwards, starting with:"-          [ Q.testProperty "no anf vars" $-              prop_no_anfs simpleUndoANFNoAnfEnv-          , Q.testProperty "single-level anf vars" $-              prop_no_anfs simpleUndoANFFlatAnfEnv-          , Q.testProperty "chained anf vars" $-              prop_no_anfs simpleUndoANFChainedAnfEnv-          ]-      ]-  where-    withOptions = adjustOption (min (Q.QuickCheckMaxSize 8))   -- adjustOption . min because we don't want to default to the enormous value.-                  . adjustOption (max (Q.QuickCheckTests 500)) -- adjustOption . max because we may want larger on the command line.---- | 5 seconds (in microseconds).-timeout :: Int-timeout = 5000000--prop_no_change :: (Q.Arbitrary e, Eq e, Show e) => (e -> M.HashMap Symbol SortedReft) -> (e -> M.HashMap Symbol SortedReft) -> e -> Q.Property-prop_no_change toHashMap f e = Q.within timeout $ f e === toHashMap e--prop_no_anfs :: (Q.Arbitrary e, Eq e, Show e) => (e -> M.HashMap Symbol SortedReft) -> e -> Q.Property-prop_no_anfs f e = Q.within timeout . checkNoAnfs . f $ e-  where-    checkNoAnfs m = M.filter (any isAnfVar . syms) m === M.empty-    isAnfVar = isPrefixOfSym anfPrefix---- | We perform tests with only trivial lenses (i.e. id)-simpleUndoANF :: [(Symbol, SortedReft)] -> M.HashMap Symbol SortedReft-simpleUndoANF = undoANFSimplifyingWith id id . M.fromList--------------------------------------------------------- | simpleUndoANF conjugated with various newtypes-------------------------------------------------------simpleUndoANFEnv :: Env -> M.HashMap Symbol SortedReft-simpleUndoANFEnv = simpleUndoANF . unEnv--simpleUndoANFNoAnfEnv :: NoAnfEnv -> M.HashMap Symbol SortedReft-simpleUndoANFNoAnfEnv = simpleUndoANFEnv . unNoAnfEnv--simpleUndoANFFlatAnfEnv :: FlatAnfEnv -> M.HashMap Symbol SortedReft-simpleUndoANFFlatAnfEnv = simpleUndoANFEnv . unFlatAnfEnv--simpleUndoANFChainedAnfEnv :: ChainedAnfEnv -> M.HashMap Symbol SortedReft-simpleUndoANFChainedAnfEnv = simpleUndoANFEnv . unChainedAnfEnv
− tests/tasty/ghc-9.12.1/SimplifyKVarTests.hs 
@@ -1,400 +0,0 @@-{-# LANGUAGE MultilineStrings #-}--module SimplifyKVarTests (tests) where--import Control.Monad (when)-import qualified Data.HashSet as HashSet-import Language.Fixpoint.Parse-import qualified Language.Fixpoint.Types as F-import qualified Language.Fixpoint.Solver.Solution as F-import Test.Tasty-import Test.Tasty.HUnit---tests :: TestTree-tests =-  testGroup "simplifyKVar" $ map simplificationTest-    [ SimplificationTest-        { name = "single elimination"-        , expected = """-            exists [y : int] . P C y-          """-        , input = """-            exists [x : int, y : int] . x == C && P x y-          """-        }--    , SimplificationTest-        { name = "full elimination"-        , expected = """-            P C D-          """-        , input = """-            exists [x : int, y : int] . x == C && P x y && y == D-          """-        }--    , SimplificationTest-        { name = "alpha equivalence"-        , expected = """-            (exists [w : int, z : int] . Q w z) &&-            (exists [w : int, z : int] . P w z)-          """-        , input = """-            (exists [w : int, z : int] . Q w z) &&-            (exists [w : int, z : int] . P w z) &&-            (exists [x : int, y : int] . P x y)-          """-        }--    , SimplificationTest-        { name = "floating"-        , expected = """-            (exists [x : int, y : int] . P x y) && A == C-          """-        , input = """-            exists [x : int, y : int] . A == C && P x y-          """-        }--    , SimplificationTest-        { name = "inner floating"-        , expected = """-            (exists [x : int] . P x && Q x) && (exists [y : int] . P y)-          """-        , input = """-            exists [x : int] . P x && (exists [ y : int] . P y && Q x)-          """-        }--    , largeSimplificationTest-    ]--data SimplificationTest = SimplificationTest-  { input :: String-  , expected :: String-  , name :: String-  }--simplificationTest :: SimplificationTest -> TestTree-simplificationTest test =-  testCase (name test) $ do-    let actual =-          F.simplifyKVar-            HashSet.empty-            (doParse'' True predP (name test) (input test))-        expectedE = doParse'' True predP (name test) (expected test)-    when (not (F.alphaEq HashSet.empty actual expectedE)) $ do-      assertFailure $ unlines-        [ "output is not as expected"-        , "Expected:"-        , expected test-        , ""-        , "Actual:"-        , F.showpp actual-        ]--largeSimplificationTest :: SimplificationTest-largeSimplificationTest =-  SimplificationTest-    { name = "large simplification"-    , expected = """-        exists [w : int] . Test.gt0xy w i##aS7-      """-    , input = """-        exists [VV##1821##k_ : int,-                i##aS7##k_ : int,-                lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                lq_tmpx##1823##k_ : int,-                lq_tmpx##1824##k_ : int]-              . (exists [w : int,-                         w2 : int,-                         x : int,-                         y : Tuple0,-                         VV##F##13 : int]-                   . VV##1821##k_ == VV##F##13-                     && i##aS7##k_ == i##aS7-                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                     && lq_tmpx##1823##k_ == w-                     && lq_tmpx##1824##k_ == x-                     && (exists [VV##1829 : int,-                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                 lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                 VV##1805##k_ : int,-                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                 i##aS7##k_ : int]-                           . VV##1829 == w-                             && VV##1805##k_ == w-                             && i##aS7##k_ == i##aS7-                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                             && (exists [VV##F##3 : int]-                                   . Test.gt0xy VV##F##3 i##aS7-                                     && VV##1805##k_ == VV##F##3-                                     && i##aS7##k_ == i##aS7-                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                     && (exists [VV##1830 : int,-                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                 i##aS7##k_ : int,-                                 lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                 VV##1807##k_ : int]-                           . VV##1830 == w2-                             && VV##1807##k_ == w2-                             && i##aS7##k_ == i##aS7-                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                             && (exists [w : int,-                                         VV##F##14 : int,-                                         lq_rnmx##255 : Tuple0]-                                   . (exists [VV##1828 : int,-                                              lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                              lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                              VV##1805##k_ : int,-                                              lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                              i##aS7##k_ : int]-                                        . VV##1828 == w-                                          && VV##1805##k_ == w-                                          && i##aS7##k_ == i##aS7-                                          && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                          && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                          && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                          && (exists [VV##F##3 : int]-                                                . Test.gt0xy VV##F##3 i##aS7-                                                  && VV##1805##k_ == VV##F##3-                                                  && i##aS7##k_ == i##aS7-                                                  && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                  && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                  && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                                     && (exists [lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                 i##aS7##k_ : int,-                                                 lq_tmpx##1812##k_ : Tuple0,-                                                 VV##1809##k_ : int,-                                                 lq_tmpx##1811##k_ : int,-                                                 lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int)]-                                           . VV##1809##k_ == VV##F##14-                                             && i##aS7##k_ == i##aS7-                                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                             && lq_tmpx##1811##k_ == w-                                             && lq_tmpx##1812##k_ == lq_rnmx##255-                                             && (exists [VV##F##12 : int,-                                                         lq_tmpx##1811 : int,-                                                         lq_tmpx##1812 : Tuple0,-                                                         lq_tmpdb##43 : int,-                                                         lq_tmpdb##44 : Tuple0]-                                                   . VV##F##12 == i##aS7-                                                     && VV##1809##k_ == VV##F##12-                                                     && i##aS7##k_ == i##aS7-                                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                                     && lq_tmpx##1811##k_ == lq_tmpx##1811-                                                     && lq_tmpx##1812##k_ == lq_tmpx##1812))-                                     && (exists [i##aS7##k_ : int,-                                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                 lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                                 lq_tmpx##1801 : Tuple0,-                                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                 VV##1799##k_ : Tuple0]-                                           . VV##1799##k_ == lq_rnmx##255-                                             && i##aS7##k_ == i##aS7-                                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                             && lq_tmpx##1801 == lq_rnmx##255-                                             && (exists [VV##F##10 : Tuple0]-                                                   . VV##1799##k_ == VV##F##10-                                                     && i##aS7##k_ == i##aS7-                                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                                     && VV##1807##k_ == VV##F##14-                                     && i##aS7##k_ == i##aS7-                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                     && (exists [i##aS7##k_ : int,-                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                 lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                 lq_tmpx##1801 : Tuple0,-                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                 VV##1799##k_ : Tuple0]-                           . VV##1799##k_ == y-                             && i##aS7##k_ == i##aS7-                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                             && lq_tmpx##1801 == y-                             && (exists [VV##F##10 : Tuple0]-                                   . VV##1799##k_ == VV##F##10-                                     && i##aS7##k_ == i##aS7-                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                     && (exists [i##aS7##k_ : int,-                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                 lq_tmpx##1804 : int,-                                 lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                 VV##1802##k_ : int]-                           . VV##1802##k_ == x-                             && i##aS7##k_ == i##aS7-                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                             && lq_tmpx##1804 == x-                             && (exists [VV##F##6 : int]-                                   . (exists [i##aS7##k_ : int,-                                              lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                              lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                              VV##1796##k_ : int]-                                        . VV##1796##k_ == VV##F##6-                                          && i##aS7##k_ == i##aS7-                                          && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                          && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                          && (exists [VV##F##7 : int]-                                                . (exists [lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                           lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                           i##aS7##k_ : int,-                                                           lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                                           VV##1807##k_ : int]-                                                     . VV##1807##k_ == VV##F##7-                                                       && i##aS7##k_ == i##aS7-                                                       && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                       && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                       && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                                       && (exists [w : int,-                                                                   VV##F##14 : int,-                                                                   lq_rnmx##255 : Tuple0]-                                                             . (exists [VV##1828 : int,-                                                                        lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                                        lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                                                        VV##1805##k_ : int,-                                                                        lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                                        i##aS7##k_ : int]-                                                                  . VV##1828 == w-                                                                    && VV##1805##k_ == w-                                                                    && i##aS7##k_ == i##aS7-                                                                    && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                                    && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                                    && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                                                    && (exists [VV##F##3 : int]-                                                                          . Test.gt0xy VV##F##3 i##aS7-                                                                            && VV##1805##k_ == VV##F##3-                                                                            && i##aS7##k_ == i##aS7-                                                                            && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                                            && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                                            && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                                                               && (exists [lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                                           lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                                           i##aS7##k_ : int,-                                                                           lq_tmpx##1812##k_ : Tuple0,-                                                                           VV##1809##k_ : int,-                                                                           lq_tmpx##1811##k_ : int,-                                                                           lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int)]-                                                                     . VV##1809##k_ == VV##F##14-                                                                       && i##aS7##k_ == i##aS7-                                                                       && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                                       && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                                       && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                                                       && lq_tmpx##1811##k_ == w-                                                                       && lq_tmpx##1812##k_ == lq_rnmx##255-                                                                       && (exists [VV##F##12 : int,-                                                                                   lq_tmpx##1811 : int,-                                                                                   lq_tmpx##1812 : Tuple0,-                                                                                   lq_tmpdb##43 : int,-                                                                                   lq_tmpdb##44 : Tuple0]-                                                                             . VV##F##12 == i##aS7-                                                                               && VV##1809##k_ == VV##F##12-                                                                               && i##aS7##k_ == i##aS7-                                                                               && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                                               && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                                               && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                                                               && lq_tmpx##1811##k_ == lq_tmpx##1811-                                                                               && lq_tmpx##1812##k_ == lq_tmpx##1812))-                                                               && (exists [i##aS7##k_ : int,-                                                                           lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                                           lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                                                           lq_tmpx##1801 : Tuple0,-                                                                           lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                                           VV##1799##k_ : Tuple0]-                                                                     . VV##1799##k_ == lq_rnmx##255-                                                                       && i##aS7##k_ == i##aS7-                                                                       && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                                       && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                                       && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                                                       && lq_tmpx##1801 == lq_rnmx##255-                                                                       && (exists [VV##F##10 : Tuple0]-                                                                             . VV##1799##k_ == VV##F##10-                                                                               && i##aS7##k_ == i##aS7-                                                                               && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                                               && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                                               && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                                                               && VV##1807##k_ == VV##F##14-                                                               && i##aS7##k_ == i##aS7-                                                               && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                               && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                                               && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                                                  && VV##1796##k_ == VV##F##7-                                                  && i##aS7##k_ == i##aS7-                                                  && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                  && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb))-                                     && (exists [i##aS7##k_ : int,-                                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                                 VV##1793##k_ : int]-                                           . VV##1793##k_ == VV##F##6-                                             && i##aS7##k_ == i##aS7-                                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                             && (exists [VV##F##5 : int]-                                                   . VV##1793##k_ == VV##F##5-                                                     && i##aS7##k_ == i##aS7-                                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb))-                                     && VV##1802##k_ == VV##F##6-                                     && i##aS7##k_ == i##aS7-                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc))-                     && (exists [lq_anf##7205759403792798200##d1cc##k_ : (Test.State int int),-                                 lq_tmpx##1818##k_ : int,-                                 lq_anf##7205759403792798198##d1ca##k_ : (GHC.Internal.Base.Monad (Test.State int)),-                                 lq_tmpx##1817##k_ : int,-                                 VV##1815##k_ : int,-                                 lq_anf##7205759403792798199##d1cb##k_ : (Test.State int Tuple0),-                                 i##aS7##k_ : int]-                           . VV##1815##k_ == VV##F##13-                             && i##aS7##k_ == i##aS7-                             && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                             && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                             && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                             && lq_tmpx##1817##k_ == w2-                             && lq_tmpx##1818##k_ == x-                             && (exists [VV##F##8 : int,-                                         lq_tmpx##1817 : int,-                                         lq_tmpx##1818 : int,-                                         lq_tmpdb##47 : int,-                                         lq_tmpdb##48 : int]-                                   . lq_tmpx##1818 == VV##F##8-                                     && VV##F##8 == lq_tmpx##1817-                                     && VV##1815##k_ == VV##F##8-                                     && i##aS7##k_ == i##aS7-                                     && lq_anf##7205759403792798198##d1ca##k_ == lq_anf##7205759403792798198##d1ca-                                     && lq_anf##7205759403792798199##d1cb##k_ == lq_anf##7205759403792798199##d1cb-                                     && lq_anf##7205759403792798200##d1cc##k_ == lq_anf##7205759403792798200##d1cc-                                     && lq_tmpx##1817##k_ == lq_tmpx##1817-                                     && lq_tmpx##1818##k_ == lq_tmpx##1818)))-        """-    }
− tests/tasty/ghc-before-9.12.1/SimplifyKVarTests.hs 
@@ -1,12 +0,0 @@--module SimplifyKVarTests (tests) where--import Test.Tasty-import Test.Tasty.HUnit--tests :: TestTree-tests =-  testGroup "simplifyKVar"-    [ testCase "Disabled because it needs MultilineStrings (ghc >= 9.12.1)" $-        return ()-    ]
tests/test.hs view
@@ -1,26 +1,24 @@ {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE FlexibleContexts     #-}-{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Main where  import qualified Control.Concurrent.STM as STM import qualified Data.Functor.Compose   as Functor import qualified Data.IntMap            as IntMap-import Control.Monad (when)+import qualified Data.Map               as Map import qualified Control.Monad.State    as State import Control.Monad.Trans.Class (lift)-import Data.List (dropWhileEnd, isSuffixOf)-import Prelude hiding (log)++import Data.Char import Data.Maybe (fromMaybe)-import Data.Monoid (Sum(..))-import Data.Proxy-import Data.Tagged+import Data.Monoid (Sum(..), (<>)) import Control.Applicative-import Options.Applicative import System.Directory import System.Exit import System.FilePath+import System.Environment import System.IO import System.IO.Error import System.Process@@ -32,45 +30,28 @@ import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.Runners.AntXML+import Paths_liquid_fixpoint  main :: IO ()-main    = do-  lfDir <- findLiquidFixpointDir-  run lfDir =<< group "Tests" [unitTests lfDir]+main    = do +  run =<< group "Tests" [unitTests]   where-    run lfDir = defaultMainWithIngredients-              [ testRunner lfDir-              , includingOptions [ Option (Proxy :: Proxy FixpointOpts) ]+    run = defaultMainWithIngredients [+                testRunner+            --  , includingOptions [ Option (Proxy :: Proxy NumThreads)+            --                     , Option (Proxy :: Proxy LiquidOpts)+            --                     , Option (Proxy :: Proxy SmtSolver) ]               ] --- | Searches for the directory of liquid-fixpoint.cabal and changes to it-findLiquidFixpointDir :: IO FilePath-findLiquidFixpointDir = do-    dir0 <- getCurrentDirectory-    let candidates = [dir0, dir0 </> "liquid-fixpoint"]-        findCabalDir :: [FilePath] -> IO (Maybe FilePath)-        findCabalDir [] = return Nothing-        findCabalDir (d:xs) = do-          let cabalFile = d </> "liquid-fixpoint.cabal"-          exists <- doesFileExist cabalFile-          if exists then-            return (Just d)-           else-            findCabalDir xs-    mDir <- findCabalDir candidates-    case mDir of-      Just d  -> return d-      Nothing -> error "Could not find liquid-fixpoint.cabal"--testRunner :: FilePath -> Ingredient-testRunner lfDir = rerunningTests+testRunner :: Ingredient+testRunner = rerunningTests                [ listingTests-               , combineReporters (myConsoleReporter lfDir) antXMLRunner-               , myConsoleReporter lfDir+               , combineReporters myConsoleReporter antXMLRunner+               , myConsoleReporter                ] -myConsoleReporter :: FilePath -> Ingredient-myConsoleReporter lfDir = combineReporters consoleTestReporter (loggingTestReporter lfDir)+myConsoleReporter :: Ingredient+myConsoleReporter = combineReporters consoleTestReporter loggingTestReporter  -- | Combine two @TestReporter@s into one. --@@ -84,154 +65,219 @@       return $ \smap -> f1 smap >> f2 smap combineReporters _ _ = error "combineReporters needs TestReporters" -unitTests :: FilePath -> IO TestTree-unitTests lfDir =-    group "All"-      [ group "original"-        [ dirTests "native-pos"           nativeCmd   "tests/pos"              posOptions skipNativePos  ExitSuccess-        , dirTests "native-neg"           nativeCmd   "tests/neg"              [] ["float.fq"]  (ExitFailure 1)-        , dirTests "elim-crash"           nativeCmd   "tests/crash"            posOptions []            (ExitFailure 1)-        , dirTests "elim-pos1"            elimCmd     "tests/pos"              posOptions []             ExitSuccess-        , dirTests "elim-pos2"            elimCmd     "tests/elim"             posOptions []             ExitSuccess-        , dirTests "elim-neg"             elimCmd     "tests/neg"              [] ["float.fq"]  (ExitFailure 1)-        , dirTests "elim-crash"           elimCmd     "tests/crash"            []                      []            (ExitFailure 1)-        , dirTests "cvc5-pos"             cvc5Cmd     "tests/pos"              posOptions skipNativePos  ExitSuccess-        , dirTests "cvc5-spec"            cvc5Cmd     "tests/cvc5"             posOptions skipNativePos  ExitSuccess-        , dirTests "proof"                elimCmd     "tests/proof"            posOptions []             ExitSuccess-        , dirTests "rankN"                elimCmd     "tests/rankNTypes"       posOptions []             ExitSuccess-        , dirTests "horn-pos-el"          elimSaveCmd "tests/horn/pos"         posOptions []             ExitSuccess-        , dirTests "horn-pos-cvc5"        cvc5Cmd     "tests/horn/pos"         posOptions []             ExitSuccess-        , dirTests "horn-neg-el"          elimSaveCmd "tests/horn/neg"         []         []            (ExitFailure 1)-        , dirTests "horn-neg-cvc5"        cvc5Cmd     "tests/horn/neg"         []         []            (ExitFailure 1)-        , dirTests "horn-pos-na"          nativeCmd   "tests/horn/pos"         posOptions []             ExitSuccess-        , dirTests "horn-neg-na"          nativeCmd   "tests/horn/neg"         []         []            (ExitFailure 1)-        ]-      , after AllSucceed "original" <$> group "saved"-        [ dirJsonTests "horn-json-pos-el" elimCmd     "tests/logs/cur/horn-pos-el" []         []             ExitSuccess-        , dirJsonTests "horn-json-neg-el" elimCmd     "tests/logs/cur/horn-neg-el" []         []            (ExitFailure 1)-        , dirHornTests "horn-smt2-pos-el" elimCmd     "tests/logs/cur/horn-pos-el" []         []             ExitSuccess-        , dirHornTests "horn-smt2-neg-el" elimCmd     "tests/logs/cur/horn-neg-el" []         []            (ExitFailure 1)-        ]-      , return $ testGroup "flags"-        [ testCase "--numeric-version" $ do-            (code, out, _) <- readProcessWithExitCode "fixpoint" ["--numeric-version"] ""-            assertEqual "Wrong exit code" ExitSuccess code-            let ver = dropWhileEnd (== '\n') out-            assertBool ("Expected a version number like X.Y.Z, got: " ++ show ver)-                       (not (null ver) && all isNumericSegment (splitOn '.' ver))-        ]-      ]-  where-    posOptions = ["--save-bfq-on-error"]+unitTests+  = group "Unit" [+      testGroup "native-pos" <$> dirTests nativeCmd "tests/pos"    skipNativePos  ExitSuccess+    , testGroup "native-neg" <$> dirTests nativeCmd "tests/neg"    ["float.fq"]   (ExitFailure 1)+    , testGroup "elim-crash" <$> dirTests nativeCmd "tests/crash"  []             (ExitFailure 1)+    , testGroup "elim-pos1"  <$> dirTests elimCmd   "tests/pos"    []             ExitSuccess+    , testGroup "elim-pos2"  <$> dirTests elimCmd   "tests/elim"   []             ExitSuccess+    , testGroup "elim-neg"   <$> dirTests elimCmd   "tests/neg"    ["float.fq"]   (ExitFailure 1)+    , 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-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) -    dirTests     n a b c d e = testGroup n <$> dirTests' n isTest a b c d e-    dirJsonTests n a b c d e = testGroup n <$> dirTests' n ("horn.json" `isSuffixOf`) a b c d e-    dirHornTests n a b c d e = testGroup n <$> dirTests' n ("horn.smt2" `isSuffixOf`) a b c d e+    -- , testGroup "todo"       <$> dirTests elimCmd   "tests/todo"   []            (ExitFailure 1)+    -- , testGroup "todo-crash" <$> dirTests elimCmd   "tests/todo-crash" []        (ExitFailure 2)+   ] -    dirTests' :: String -> (FilePath -> Bool) -> TestCmd -> FilePath -> [String] -> [FilePath] -> ExitCode -> IO [TestTree]-    dirTests' testName isT testCmd root extraOpts ignored code = do-      let absRoot = lfDir </> root-      files    <- walkDirectory absRoot-      let tests = [ rel | f <- files, isT f, let rel = makeRelative absRoot f, rel `notElem` ignored ]-          saveDir = "--save-dir=" ++ lfDir </> "tests" </> "logs" </> "cur" </> testName-      return $ mkTest testName testCmd code (saveDir : extraOpts) absRoot <$> tests -isTest   :: FilePath -> Bool-isTest f = takeExtension f `elem` [".fq", ".smt2"]- skipNativePos :: [FilePath] skipNativePos = ["NonLinear-pack.fq"] -newtype FixpointOpts = LO String deriving (Show, Read, Eq, Ord)--instance Semigroup FixpointOpts where-  (LO "") <> y       = y-  x       <> (LO "") = x-  (LO x)  <> (LO y)  = LO $ x ++ (' ' : y)--instance Monoid FixpointOpts where-  mempty = LO ""-  mappend = (<>)+---------------------------------------------------------------------------+dirTests :: TestCmd -> FilePath -> [FilePath] -> ExitCode -> IO [TestTree]+---------------------------------------------------------------------------+dirTests testCmd root ignored code = do +  files    <- walkDirectory root+  let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ]+  return    $ mkTest testCmd code root <$> tests -instance IsOption FixpointOpts where-  defaultValue = LO ""-  parseValue = Just . LO-  optionName = return "fixpoint-opts"-  optionHelp = return "Extra options to pass to fixpoint"-  optionCLParser =-    option (fmap LO str)-      (  long (untag (optionName :: Tagged FixpointOpts String))-      <> help (untag (optionHelp :: Tagged FixpointOpts String))-      )+isTest   :: FilePath -> Bool+isTest f = takeExtension f `elem` [".fq", ".smt2"]  ----------------------------------------------------------------------------mkTest :: String -> TestCmd -> ExitCode -> [String] -> FilePath -> FilePath -> TestTree+mkTest :: TestCmd -> ExitCode -> FilePath -> FilePath -> TestTree ----------------------------------------------------------------------------mkTest testName testCmd code extraOpts dir file-  =-    askOption $ \opts ->-    testCase file $+mkTest testCmd code dir file+  = testCase file $       if test `elem` knownToFail       then do         printf "%s is known to fail: SKIPPING" test         assertEqual "" True True       else do         createDirectoryIfMissing True $ takeDirectory log-        c <- withFile log WriteMode $ \h -> do-          let cmd     = testCmd (LO (unwords extraOpts) <> opts) "fixpoint" dir file+        withFile log WriteMode $ \h -> do+          let cmd     = testCmd "fixpoint" dir file           (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h}-          waitForProcess ph-        when (code /= c) $-          readFile log >>= putStrLn-        assertEqual "Wrong exit code" code c-+          c          <- waitForProcess ph+          assertEqual "Wrong exit code" code c   where     test = dir </> file-    -- select a file name that is unique to the test, as the tests might run-    -- in parallel.-    log  = let (d,f) = splitFileName file in dir </> d </> ".liquid" </> testName </> f <.> "harness.log"+    log  = let (d,f) = splitFileName file in dir </> d </> ".liquid" </> f <.> "log" -knownToFail :: [a] knownToFail = [] ----------------------------------------------------------------------------type TestCmd = FixpointOpts -> FilePath -> FilePath -> FilePath -> String+type TestCmd = FilePath -> FilePath -> FilePath -> String  nativeCmd :: TestCmd-nativeCmd (LO opts) bin dir file =-  printf "cd %s && %s %s %s" dir bin opts file+nativeCmd bin dir file = printf "cd %s && %s %s" dir bin file  elimCmd :: TestCmd-elimCmd (LO opts) bin dir file =-  printf "cd %s && %s --eliminate=some %s %s" dir bin opts file+elimCmd bin dir file = printf "cd %s && %s --eliminate=some %s" dir bin file -elimSaveCmd :: TestCmd-elimSaveCmd (LO opts) bin dir file =-  printf "cd %s && %s --save --eliminate=some %s %s" dir bin opts file -cvc5Cmd :: TestCmd-cvc5Cmd (LO opts) bin dir file =-  printf "cd %s && %s --solver=cvc5 %s %s" dir bin opts file +++++++++++++---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------+---------------------------------------------------------------------------++{-++quickCheckTests :: TestTree+quickCheckTests+  = testGroup "Properties"+      [ testProperty "prop_pprint_parse_inv_expr" prop_pprint_parse_inv_expr+      , testProperty "prop_pprint_parse_inv_pred" prop_pprint_parse_inv_pred+      ]++prop_pprint_parse_inv_pred :: Pred -> Bool+prop_pprint_parse_inv_pred p = p == rr (showpp p)++prop_pprint_parse_inv_expr :: Expr -> Bool+prop_pprint_parse_inv_expr p = simplify p == rr (showpp $ simplify p)++instance Arbitrary Sort where+  arbitrary = sized arbSort++arbSort 0 = oneof [return FInt, return FReal, return FNum]+arbSort n = frequency+              [(1, return FInt)+              ,(1, return FReal)+              ,(1, return FNum)+              ,(2, fmap FObj arbitrary)+              ]+++instance Arbitrary Pred where+  arbitrary = sized arbPred+  shrink = filter valid . genericShrink+    where+      valid (PAnd [])  = False+      valid (PAnd [_]) = False+      valid (POr [])   = False+      valid (POr [_])  = False+      valid (PBexp (EBin _ _ _)) = True+      valid (PBexp _)  = False+      valid _          = True++arbPred 0 = elements [PTrue, PFalse]+arbPred n = frequency+              [(1, return PTrue)+              ,(1, return PFalse)+              ,(2, fmap PAnd  twoPreds)+              ,(2, fmap POr   twoPreds)+              ,(2, fmap PNot (arbPred (n `div` 2)))+              ,(2, liftM2 PImp (arbPred (n `div` 2)) (arbPred (n `div` 2)))+              ,(2, liftM2 PIff (arbPred (n `div` 2)) (arbPred (n `div` 2)))+              ,(2, fmap PBexp (arbExpr (n `div` 2)))+              ,(2, liftM3 PAtom arbitrary (arbExpr (n `div` 2)) (arbExpr (n `div` 2)))+              -- ,liftM2 PAll arbitrary arbitrary+              -- ,return PTop+              ]+  where+    twoPreds = do+      x <- arbPred (n `div` 2)+      y <- arbPred (n `div` 2)+      return [x,y]++instance Arbitrary Expr where+  arbitrary = sized arbExpr+  shrink = filter valid . genericShrink+    where valid (EApp _ []) = False+          valid _           = True++arbExpr 0 = oneof [fmap ESym arbitrary, fmap ECon arbitrary, fmap EVar arbitrary, return EBot]+arbExpr n = frequency+              [(1, fmap ESym arbitrary)+              ,(1, fmap ECon arbitrary)+              ,(1, fmap EVar arbitrary)+              ,(1, return EBot)+              -- ,liftM2 ELit arbitrary arbitrary -- restrict literals somehow+              ,(2, choose (1,3) >>= \m -> liftM2 EApp arbitrary (vectorOf m (arbExpr (n `div` 2))))+              ,(2, liftM3 EBin arbitrary (arbExpr (n `div` 2)) (arbExpr (n `div` 2)))+              ,(2, liftM3 EIte (arbPred (max 2 (n `div` 2)) `suchThat` isRel)+                               (arbExpr (n `div` 2))+                               (arbExpr (n `div` 2)))+              ,(2, liftM2 ECst (arbExpr (n `div` 2)) (arbSort (n `div` 2)))+              ]+  where+    isRel (PAtom _ _ _) = True+    isRel _             = False++instance Arbitrary Brel where+  arbitrary = oneof (map return [Eq, Ne, Gt, Ge, Lt, Le, Ueq, Une])++instance Arbitrary Bop where+  arbitrary = oneof (map return [Plus, Minus, Times, Div, Mod])++instance Arbitrary SymConst where+  arbitrary = fmap SL arbitrary++instance Arbitrary Symbol where+  arbitrary = fmap (symbol :: Text -> Symbol) arbitrary++instance Arbitrary Text where+  arbitrary = choose (1,4) >>= \n ->+                fmap pack (vectorOf n char `suchThat` valid)+    where+      char = elements ['a'..'z']+      valid x = x `notElem` fixpointNames && not (isFixKey x)++instance Arbitrary FTycon where+  arbitrary = do+    c <- elements ['A'..'Z']+    t <- arbitrary+    return $ symbolFTycon $ dummyLoc $ symbol $ cons c t++instance Arbitrary Constant where+  arbitrary = oneof [fmap I (arbitrary `suchThat` (>=0))+                    -- ,fmap R arbitrary+                    ]+  shrink = genericShrink++instance Arbitrary a => Arbitrary (Located a) where+  arbitrary = fmap dummyLoc arbitrary+  shrink = fmap dummyLoc . shrink . val++-}+ ---------------------------------------------------------------------------------------- -- Generic Helpers ---------------------------------------------------------------------------------------- -group :: Monad f => TestName -> [f TestTree] -> f TestTree group n xs = testGroup n <$> sequence xs --- | Split a string on a delimiter character.-splitOn :: Char -> String -> [String]-splitOn _ [] = [""]-splitOn d (c:cs)-  | c == d    = "" : splitOn d cs-  | otherwise = case splitOn d cs of-      (w:ws) -> (c:w) : ws-      []     -> [c:""]---- | A numeric version segment is a non-empty string of digits.-isNumericSegment :: String -> Bool-isNumericSegment s = not (null s) && all (\c -> c >= '0' && c <= '9') s- ---------------------------------------------------------------------------------------- walkDirectory :: FilePath -> IO [FilePath] ----------------------------------------------------------------------------------------@@ -239,7 +285,7 @@   = do (ds,fs) <- partitionM doesDirectoryExist . candidates =<< (getDirectoryContents root `catchIOError` const (return []))        (fs++) <$> concatMapM walkDirectory ds   where-    candidates fs = [root </> f | f@(c:_) <- fs, not (isExtSeparator c)]+    candidates fs = [root </> f | f <- fs, not (isExtSeparator (head f))]  partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a]) partitionM f = go [] []@@ -260,8 +306,8 @@  -- this is largely based on ocharles' test runner at -- https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs#L65-loggingTestReporter :: FilePath -> Ingredient-loggingTestReporter lfDir = TestReporter [] $ \opts tree -> Just $ \smap -> do+loggingTestReporter :: Ingredient+loggingTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do   let     runTest _ testName _ = Traversal $ Functor.Compose $ do         i <- State.get@@ -287,9 +333,9 @@          Const summary <$ State.modify (+ 1) -    runGroup _ group' children = Traversal $ Functor.Compose $ do-      Const soFar <- Functor.getCompose $ getTraversal $ mconcat children-      pure $ Const $ map (\(n,t,s) -> (group' </> n,t,s)) soFar+    runGroup _ group children = Traversal $ Functor.Compose $ do+      Const soFar <- Functor.getCompose $ getTraversal children+      pure $ Const $ map (\(n,t,s) -> (group</>n,t,s)) soFar      computeFailures :: StatusMap -> IO Int     computeFailures = fmap getSum . getApp . foldMap (\var -> Ap $@@ -311,7 +357,10 @@         tree    return $ \_elapsedTime -> do+    -- get some semblance of a hostname+    host <- takeWhile (/='.') . takeWhile (not . isSpace) <$> readProcess "hostname" [] []     -- don't use the `time` package, major api differences between ghc 708 and 710+    time <- head . lines <$> readProcess "date" ["+%Y-%m-%dT%H-%M-%S"] []     -- build header     ref <- gitRef     timestamp <- gitTimestamp@@ -324,10 +373,12 @@                        "test, time(s), result"]  -    let smry = lfDir </> "tests" </> "logs" </> "cur" </> "summary.csv"+    let dir = "tests" </> "logs" </> host ++ "-" ++ time+    let smry = "tests" </> "logs" </> "cur" </> "summary.csv"     writeFile smry $ unlines                    $ hdr                    : map (\(n, t, r) -> printf "%s, %0.4f, %s" n t (show r)) summary+    -- system $ "cp -r tests/logs/cur " ++ dir     (==0) <$> computeFailures smap  @@ -353,7 +404,7 @@  -- | Calls `git` for info; returns `"plain"` if we are not in a git directory. gitProcess :: [String] -> IO String-gitProcess args = readProcess "git" args [] `catchIOError` const (return "plain")+gitProcess args = (readProcess "git" args []) `catchIOError` const (return "plain")  notNoise :: Char -> Bool notNoise a = a /= '\"' && a /= '\n' && a /= '\r'
+ 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]}+
unix/Language/Fixpoint/Utils/Progress.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE ForeignFunctionInterface #-} -- | Progress Bar API module Language.Fixpoint.Utils.Progress (       withProgress-    , withProgressM     , progressInit     , progressTick     , progressClose@@ -10,49 +8,38 @@  import           Control.Monad                    (when) import           System.IO.Unsafe                 (unsafePerformIO)-import           Language.Fixpoint.Verbosity      (isNormal, getVerbosity, Verbosity(..))+import           System.Console.CmdArgs.Verbosity (isNormal, getVerbosity, Verbosity(..)) import           Data.IORef import           System.Console.AsciiProgress -- import           Language.Fixpoint.Misc (traceShow) -foreign import ccall unsafe "unistd.h isatty"-  c_isatty :: Int -> IO Int- {-# NOINLINE pbRef #-} pbRef :: IORef (Maybe ProgressBar) pbRef = unsafePerformIO (newIORef Nothing)  withProgress :: Int -> IO a -> IO a-withProgress = withProgressM id--withProgressM :: (m a -> IO b) -> Int -> m a -> IO b-withProgressM mToIO n act = do-  showBar <- (Quiet /=) <$> getVerbosity-  -- We don't show the progress bar if the output is not a terminal.-  -- Besides improving the output, this also avoids a concurrency-  -- issue:-  -- https://github.com/ucsd-progsys/liquid-fixpoint/issues/782-  isTTY <- (== 1) <$> c_isatty 1-  if showBar && isTTY-    then displayConsoleRegions $ do+withProgress n act = do+  showBar <- ((/=) Quiet) <$> getVerbosity+  case showBar of+    False -> act+    True  -> displayConsoleRegions $ do       -- putStrLn $ "withProgress: " ++ show n       progressInit n-      r <- mToIO act+      r <- act       progressClose       return r-    else mToIO act-+   progressInit :: Int -> IO () progressInit n = do-  normal <- isNormal+  normal <- isNormal    when normal $ do     pr <- mkPB n     writeIORef pbRef (Just pr)  mkPB   :: Int -> IO ProgressBar-mkPB n = newProgressBar def+mkPB n = newProgressBar def    { pgWidth       = 80-  , pgTotal       = {- traceShow "MAKE-PROGRESS" -} toInteger n+  , pgTotal       = {- traceShow "MAKE-PROGRESS" -} (toInteger n)   , pgFormat      = "Working :percent [:bar]"   , pgPendingChar = '.'   , pgOnCompletion = Nothing@@ -64,15 +51,15 @@    go (Just pr) = incTick pr    go _         = return () -incTick :: ProgressBar -> IO ()+incTick :: ProgressBar -> IO ()  incTick pb = do-  st <- getProgressStats pb+  st <- getProgressStats pb    when (incomplete st) (tick pb)     -- then tick pb -- putStrLn (show (stPercent st, stTotal st, stCompleted st)) >> (tick pb)-    -- else return ()+    -- else return ()  -incomplete :: Stats -> Bool-incomplete st = {- traceShow "INCOMPLETE" -} stRemaining st > 0+incomplete :: Stats -> Bool +incomplete st = {- traceShow "INCOMPLETE" -} (stRemaining st) > 0  -- incomplete st = stPercent st < 100
win/Language/Fixpoint/Utils/Progress.hs view
@@ -1,7 +1,6 @@ -- | Progress Bar API module Language.Fixpoint.Utils.Progress (       withProgress-    , withProgressM     , progressInit     , progressTick     , progressClose@@ -9,9 +8,6 @@  withProgress :: Int -> IO a -> IO a withProgress _ x = x--withProgressM :: (m a -> IO b) -> Int -> m a -> IO b-withProgressM f _ = f  progressInit :: Int -> IO () progressInit _ = return ()