liquid-fixpoint 0.9.6.3.3 → 0.9.6.3.4

raw patch · 129 files changed

+4184/−5364 lines, 129 filesdep +gitrevdep −parallelPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: gitrev

Dependencies removed: parallel

API changes (from Hackage documentation)

Files

• CHANGES.md +29/−0
• README.md +63/−26
• bin/Fixpoint.hs +2/−2
• liquid-fixpoint.cabal +10/−7
• src/Control/Exception/Compat.hs +28/−0
• src/Language/Fixpoint/Defunctionalize.hs +3/−5
• src/Language/Fixpoint/Graph/Deps.hs +16/−27
• src/Language/Fixpoint/Graph/Types.hs +2/−4
• src/Language/Fixpoint/Horn/Info.hs +22/−37
• src/Language/Fixpoint/Horn/Parse.hs +1/−2
• src/Language/Fixpoint/Horn/SMTParse.hs +14/−3
• src/Language/Fixpoint/Horn/Solve.hs +5/−5
• src/Language/Fixpoint/Horn/Transformations.hs +16/−67
• src/Language/Fixpoint/Horn/Types.hs +38/−169
• src/Language/Fixpoint/Minimize.hs +5/−0
• src/Language/Fixpoint/Parse.hs +101/−286
• src/Language/Fixpoint/Smt/Interface.hs +197/−135
• src/Language/Fixpoint/Smt/Serialize.hs +229/−151
• src/Language/Fixpoint/Smt/Theories.hs +116/−52
• src/Language/Fixpoint/Smt/Types.hs +44/−5
• src/Language/Fixpoint/Solver.hs +79/−160
• src/Language/Fixpoint/Solver/Common.hs +19/−10
• src/Language/Fixpoint/Solver/Eliminate.hs +40/−14
• src/Language/Fixpoint/Solver/EnvironmentReduction.hs +18/−15
• src/Language/Fixpoint/Solver/Extensionality.hs +4/−3
• src/Language/Fixpoint/Solver/GradualSolution.hs +0/−135
• src/Language/Fixpoint/Solver/GradualSolve.hs +0/−328
• src/Language/Fixpoint/Solver/Instantiate.hs +0/−816
• src/Language/Fixpoint/Solver/Interpreter.hs +8/−6
• src/Language/Fixpoint/Solver/Monad.hs +43/−81
• src/Language/Fixpoint/Solver/PLE.hs +471/−238
• src/Language/Fixpoint/Solver/Rewrite.hs +15/−5
• src/Language/Fixpoint/Solver/Sanitize.hs +21/−55
• src/Language/Fixpoint/Solver/Solution.hs +303/−287
• src/Language/Fixpoint/Solver/Solve.hs +183/−171
• src/Language/Fixpoint/Solver/UniqifyKVars.hs +5/−5
• src/Language/Fixpoint/Solver/Worklist.hs +6/−4
• src/Language/Fixpoint/SortCheck.hs +251/−75
• src/Language/Fixpoint/Types.hs +1/−0
• src/Language/Fixpoint/Types/Config.hs +36/−42
• src/Language/Fixpoint/Types/Constraints.hs +142/−105
• src/Language/Fixpoint/Types/Environments.hs +1/−1
• src/Language/Fixpoint/Types/Errors.hs +3/−2
• src/Language/Fixpoint/Types/Graduals.hs +0/−259
• src/Language/Fixpoint/Types/Names.hs +54/−63
• src/Language/Fixpoint/Types/Refinements.hs +23/−88
• src/Language/Fixpoint/Types/SMTPrint.hs +130/−0
• src/Language/Fixpoint/Types/Solutions.hs +47/−194
• src/Language/Fixpoint/Types/Sorts.hs +29/−8
• src/Language/Fixpoint/Types/Substitutions.hs +150/−31
• src/Language/Fixpoint/Types/Templates.hs +2/−2
• src/Language/Fixpoint/Types/Theories.hs +123/−119
• src/Language/Fixpoint/Types/Utils.hs +10/−9
• src/Language/Fixpoint/Types/Visitor.hs +13/−24
• src/Language/Fixpoint/Utils/Builder.hs +4/−0
• src/Language/Fixpoint/Utils/Files.hs +5/−5
• tests/neg/ebind-00.fq +0/−16
• tests/neg/ebind-01.fq +0/−17
• tests/neg/ebind-02.fq +0/−28
• tests/neg/ebind-03.fq +0/−45
• tests/neg/ebind-04.fq +0/−35
• tests/neg/ebind-elim2.fq +0/−26
• tests/neg/elim-dep-00.fq +3/−3
• tests/neg/qualif-template-00.fq +1/−1
• tests/neg/qualif-template-01.fq +1/−1
• tests/neg/qualif-template-02.fq +1/−1
• tests/neg/test00.fq +2/−2
• tests/neg/test00.hs.fq +60/−60
• tests/neg/test00a.fq +1/−1
• tests/neg/test1.fq +1/−1
• tests/neg/test2.fq +2/−2
• tests/neg/test3.fq +1/−1
• tests/pos/LogicCurry1.hs.fq +41/−41
• tests/pos/MergeSort.fq +49/−49
• tests/pos/T416.fq +2/−2
• tests/pos/T753A.fq +45/−0
• tests/pos/adt_qual.fq +2/−2
• tests/pos/bad-subst00.fq +2/−2
• tests/pos/bad-subst01.fq +2/−2
• tests/pos/bad-subst02.fq +1/−1
• tests/pos/bool00.fq +2/−2
• tests/pos/bool03.fq +1/−1
• tests/pos/bool04.fq +0/−20
• tests/pos/ebind-00.fq +0/−16
• tests/pos/ebind-01.fq +0/−17
• tests/pos/ebind-02.fq +0/−28
• tests/pos/ebind-03.fq +0/−45
• tests/pos/ebind-03a.fq +0/−55
• tests/pos/ebind-04.fq +0/−35
• tests/pos/ebind-05.fq +0/−31
• tests/pos/ebind-06.fq +0/−27
• tests/pos/elim00.fq +2/−2
• tests/pos/func00.fq +1/−1
• tests/pos/gfp00.fq +4/−4
• tests/pos/hex.ts.fq +78/−78
• tests/pos/kvar-param-poly-00.fq +1/−1
• tests/pos/len00-rename.fq +1/−1
• tests/pos/len00.fq +1/−1
• tests/pos/listqual.hs.fq +58/−58
• tests/pos/meas02.fq +2/−2
• tests/pos/min00.fq +4/−4
• tests/pos/num00.fq +1/−1
• tests/pos/numoverload00.fq +2/−2
• tests/pos/qualif-inst.fq +1/−1
• tests/pos/qualif-template-00.fq +1/−1
• tests/pos/qualif-template-01.fq +1/−1
• tests/pos/qualif-template-02.fq +1/−1
• tests/pos/sets.fq +1/−1
• tests/pos/test00.fq +2/−2
• tests/pos/test00.hs.fq +65/−65
• tests/pos/test000.hs.fq +70/−70
• tests/pos/test00a.fq +1/−1
• tests/pos/test1.fq +1/−1
• tests/pos/test2.fq +2/−2
• tests/pos/test3.fq +1/−1
• tests/pos/test4.fq +1/−1
• tests/pos/unexpected-ge.fq +1/−1
• tests/pos/wl00.fq +3/−3
• tests/pos/wl01.fq +1/−1
• tests/pos/wl02.fq +1/−1
• tests/tasty/Arbitrary.hs +2/−9
• tests/tasty/Main.hs +2/−0
• tests/tasty/ParserTests.hs +11/−59
• tests/tasty/SimplifyPLE.hs +6/−4
• tests/tasty/ghc-9.12.1/SimplifyKVarTests.hs +400/−0
• tests/tasty/ghc-before-9.12.1/SimplifyKVarTests.hs +12/−0
• tests/test.hs +21/−20
• unix/Language/Fixpoint/Utils/Progress.hs +17/−4
• win/Language/Fixpoint/Utils/Progress.hs +4/−0

@@ -2,6 +2,35 @@  ## NEXT +## 0.9.6.3.4 (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).

@@ -2,7 +2,7 @@ ===============  -[![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) +[![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)@@ -15,7 +15,13 @@ + [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 ------------ @@ -23,6 +29,7 @@  - [Z3](https://github.com/Z3Prover/z3) - [CVC4](https://cvc4.github.io/)+- [CVC5](https://cvc5.github.io/) - [MathSat](http://mathsat.fbk.eu/download.html)  If on Windows, please make sure to place the binary and any associated DLLs somewhere@@ -60,9 +67,10 @@      * Z3     * CVC4+    * CVC5     * MathSat -"Horn" Format +"Horn" Format -------------  See the examples in `tests/horn/{pos, neg}` eg@@ -73,8 +81,8 @@  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)@@ -145,7 +153,7 @@ ``` $ more tests/horn/pos/test01.smt2 | fixpoint --stdin -Liquid-Fixpoint Copyright 2013-21 Regents of the University of California.+Liquid-Fixpoint Copyright 2009-25 Regents of the University of California. All Rights Reserved.  Working 166% [===============================================================]@@ -226,15 +234,20 @@   Then a single `IBindEnv` should only mention _at most_   one of `1` or `12`. -* There is also a "tree-shape" property that its a bit hard-  to describe ... TODO     +* [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'+```+ ### LHS  Each `slhs` of a constraint is a `SortedReft`.  - Each `SortredReft` is basically a `Reft` -- a logical predicate.-  The important bit is that a `KVar` i.e. terms of the formalized+  The important bit is that a `KVar` i.e. terms of the form  ```      $k1[x1:=y1][x2:=y2]...[xn:=yn]@@ -271,16 +284,35 @@    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]+```+ ### Global vs. Distinct Literals  ```      , gLits    :: !(SEnv Sort)               -- ^ Global Constant symbols-     , dLits    :: !(SEnv Sort)       +     , dLits    :: !(SEnv Sort) ```  The _global_ literals `gLits` are symbols that@@ -326,15 +358,10 @@  > What's the difference between an FTC and an FObj? -In early versions of fixpoint, there was support for -three sorts for expressions (`Expr`) that were sent -to the SMT solver:--1. `int`-2. `bool`-3. "other"--The `FObj` sort was introduced to represent essentially _all_ +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_ non-int and non-bool values (e.g. tuples, lists, trees, pointers...)  However, we later realized that it is valuable to keep _more_@@ -351,17 +378,27 @@ > Does that then make FTC types that the SMT solver does > know about (bools, ints, lists, sets, etc.)? -The SMT solver knows about `bool`, `int` and `set` (also `bitvector` -and `map`) but _all_ other types are _currently_ represented as plain -`Int` inside the SMT solver. However, we _will be_ changing this +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 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"

@@ -24,10 +24,10 @@       | otherwise  = solveFQ  isHorn :: F.Config -> Bool-isHorn cfg = F.isExtFile F.Smt2 file +isHorn cfg = F.isExtFile F.Smt2 file           || F.isExtFile F.Json file           || F.stdin cfg-  where +  where     file = F.srcFile cfg  errorExit :: F.Error -> IO ExitCode

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               liquid-fixpoint-version:            0.9.6.3.3+version:            0.9.6.3.4 synopsis:           Predicate Abstraction-based Horn-Clause/Implication Constraint Solver description:   This package implements an SMTLIB based Horn-Clause\/Logical Implication constraint@@ -56,6 +56,7 @@ library   import: warnings   exposed-modules:  Data.ShareMap+                    Control.Exception.Compat                     Language.Fixpoint.Conditional.Z3                     Language.Fixpoint.Defunctionalize                     Language.Fixpoint.Graph@@ -82,9 +83,6 @@                     Language.Fixpoint.Solver.Eliminate                     Language.Fixpoint.Solver.EnvironmentReduction                     Language.Fixpoint.Solver.Extensionality-                    Language.Fixpoint.Solver.GradualSolution-                    Language.Fixpoint.Solver.GradualSolve-                    Language.Fixpoint.Solver.Instantiate                     Language.Fixpoint.Solver.Interpreter                     Language.Fixpoint.Solver.Monad                     Language.Fixpoint.Solver.PLE@@ -105,8 +103,8 @@                     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@@ -144,12 +142,12 @@                   , directory                   , fgl                   , filepath+                  , gitrev              >= 1.3.1                   , hashable                   , intern                   , lens-family                   , megaparsec           >= 7.0.0 && < 10                   , mtl-                  , parallel                   , parser-combinators                   , pretty               >= 1.1.3.1                   , process@@ -194,7 +192,7 @@   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+  build-depends:    base >= 4.9.1.0 && < 5, liquid-fixpoint, gitrev >= 1.3.1   if flag(devel)     ghc-options: -Werror   default-language: Haskell98@@ -236,10 +234,15 @@                     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

@@ -0,0 +1,28 @@+{-# 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+

@@ -85,6 +85,9 @@                               (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@@ -152,11 +155,6 @@     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

@@ -205,12 +205,16 @@ 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 ++ concatMap (ebindEdges ebs bs) cs+kvEdges fi = selfes ++ concatMap (subcEdges 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]@@ -220,21 +224,6 @@ fiKVars :: F.GInfo c a -> [F.KVar] fiKVars = M.keys . F.ws -ebindEdges :: (F.TaggedC c a) => [F.BindId] -> F.BindEnv a -> c a -> [CEdge]-ebindEdges ebs bs c =  [(EBind k, Cstr i ) | k  <- envEbinds xs bs c ]-                    ++ [(Cstr i, EBind k') | k' <- rhsEbinds xs c ]-  where-    i          = F.subcId c-    xs         = fst3 . flip F.lookupBindEnv bs <$> ebs--envEbinds :: (F.TaggedC c a, Foldable t) =>-             t F.Symbol -> F.BindEnv a -> c a -> [F.Symbol]-envEbinds xs be c = [ x | x <- envBinds , x `elem` xs ]-  where envBinds = fst <$> F.clhs be c-rhsEbinds :: (Foldable t, F.TaggedC c a) =>-             t F.Symbol -> c a -> [F.Symbol]-rhsEbinds xs c = [ x | x <- F.syms (F.crhs c) , x `elem` xs ]- subcEdges :: (F.TaggedC c a) => F.BindEnv a -> c a -> [CEdge] subcEdges bs c =  [(KVar k, Cstr i ) | k  <- V.envKVars bs c]                ++ [(Cstr i, KVar k') | k' <- V.rhsKVars c ]@@ -245,10 +234,10 @@ -- | Eliminated Dependencies -------------------------------------------------------------------------------- {-# SCC elimDeps #-}-elimDeps :: (F.TaggedC c a) => F.GInfo c a -> [CEdge] -> S.HashSet F.KVar -> S.HashSet F.Symbol -> CDeps-elimDeps si es nonKutVs ebs = graphDeps si es'+elimDeps :: (F.TaggedC c a) => F.GInfo c a -> [CEdge] -> S.HashSet F.KVar -> CDeps+elimDeps si es nonKutVs = graphDeps si es'   where-    es'                 = graphElim es nonKutVs ebs+    es'                 = graphElim es nonKutVs     _msg                = "graphElim: " ++ show (length es')  {- | `graphElim` "eliminates" a kvar k by replacing every "path"@@ -259,9 +248,8 @@            ki ------------> c -}-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+graphElim :: [CEdge] -> S.HashSet F.KVar -> [CEdge]+graphElim es ks = ikvgEdges $ elimKs (S.map KVar ks)   $ edgesIkvg es   where     elimKs      = flip (S.foldl' elimK)     _elimEs      = flip (S.foldl' elimE)@@ -307,8 +295,10 @@ dCut    v = Deps (S.singleton v) S.empty  ----------------------------------------------------------------------------------- | Compute Dependencies and Cuts ------------------------------------------------------------------------------------------------------------------------------+-- | 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. {-# SCC elimVars #-} elimVars :: (F.TaggedC c a) => Config -> F.GInfo c a -> ([CEdge], Elims F.KVar) --------------------------------------------------------------------------------@@ -581,9 +571,8 @@     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

@@ -66,13 +66,11 @@  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 "*" @@ -192,8 +190,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 b = SI-  { siSol     :: !(F.Sol b F.QBind)             -- ^ the initial solution+data SolverInfo a = SI+  { siSol     :: !(F.Sol 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

@@ -5,12 +5,10 @@     hornFInfo   ) where -import           Control.Monad (forM) import           Data.Ord (Down(..), comparing) import qualified Data.HashMap.Strict            as M import qualified Data.List                      as L import qualified Data.Tuple                     as Tuple-import           Data.Either                    (partitionEithers) import           GHC.Generics                   (Generic) import qualified Language.Fixpoint.Misc         as Misc import qualified Language.Fixpoint.Types        as F@@ -22,7 +20,6 @@ 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.gLits     = F.fromMapSEnv $ H.qCon q@@ -30,12 +27,12 @@   , F.ae        = axEnv cfg q cs   , F.ddecls    = H.qData q   , F.hoInfo    = F.cfgHoInfo cfg-  , F.defns     = H.qDefs q+  , F.defns     = F.MkDefinedFuns (H.qDefs q)   }   where     be0         = F.emptyBindEnv     (be1, kve)  = hornWfs   be0     (H.qVars q)-    (be2, ebs, cs) = hornSubCs be1 kve hCst+    (be2, cs) = hornSubCs be1 kve hCst     hCst           = H.qCstr q  @@ -48,27 +45,26 @@  ---------------------------------------------------------------------------------- hornSubCs :: F.BindEnv a -> KVEnv a -> H.Cstr a-          -> (F.BindEnv a, [F.BindId], M.HashMap F.SubcId (F.SubC a))+          -> (F.BindEnv a, M.HashMap F.SubcId (F.SubC a)) -----------------------------------------------------------------------------------hornSubCs be kve c = (be', ebs, M.fromList (F.addIds cs))+hornSubCs be kve c = (be', M.fromList (F.addIds cs))   where-    (be', ebs, cs) = goS kve F.emptyIBindEnv be c+    (be', cs) = goS kve F.emptyIBindEnv be c     -- lhs0           = bindSortedReft kve H.dummyBind  -- | @goS@ recursively traverses the NNF constraint to build up a list --   of the vanilla @SubC@ constraints.  goS :: KVEnv a -> F.IBindEnv ->  F.BindEnv a -> H.Cstr a-    -> (F.BindEnv a, [F.BindId], [F.SubC a])+    -> (F.BindEnv a, [F.SubC a]) -goS kve env be c = (be', mEbs, subcs)+goS kve env be c = (be', subcs)   where-    (be', ecs) = goS' kve env Nothing be c-    (mEbs, subcs) = partitionEithers ecs+    (be', subcs) = goS' kve env Nothing be c  goS' :: KVEnv a -> F.IBindEnv -> Maybe F.SortedReft -> F.BindEnv a -> H.Cstr a-    -> (F.BindEnv a, [Either F.BindId (F.SubC a)])-goS' kve env lhs be (H.Head p l) = (be, [Right subc])+    -> (F.BindEnv a, [F.SubC a])+goS' kve env lhs be (H.Head p l) = (be, [subc])   where     subc                        = myMkSubC env lhs rhs Nothing [] l     rhs                         = updSortedReft kve lhs p@@ -84,13 +80,6 @@     bSR                         = bindSortedReft kve b     env'                        = F.insertsIBindEnv [bId] env -goS' kve env _   be (H.Any b c)  = (be'', Left bId : subcs)-  where-    (be'', subcs)               = goS' kve env' (Just bSR) be' c-    (bId, be')                  = F.insertBindEnv (H.bSym b) bSR (H.bMeta b) be-    bSR                         = bindSortedReft kve b-    env'                        = F.insertsIBindEnv [bId] env- myMkSubC :: F.IBindEnv -> Maybe F.SortedReft -> F.SortedReft -> Maybe Integer -> F.Tag -> a -> F.SubC a myMkSubC be lhsMb rhs x y z = F.mkSubC be lhs rhs x y z   where@@ -114,10 +103,10 @@     go (H.Var k ys) = kvApp kve k ys     go (H.PAnd  ps) = F.PAnd (go <$> ps) -kvApp :: KVEnv a -> F.Symbol -> [F.Symbol] -> F.Expr+kvApp :: KVEnv a -> F.Symbol -> [F.Expr] -> F.Expr kvApp kve k ys = F.PKVar (F.KV k) su   where-    su         = F.mkSubst (zip params (F.eVar <$> ys))+    su         = F.mkSubst (zip params ys)     params     = maybe err1 kvParams (M.lookup k kve)     err1       = F.panic ("Unknown Horn variable: " ++ F.showpp k) @@ -176,7 +165,6 @@     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-    go senv (H.Any 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)@@ -189,16 +177,17 @@  -- NOTE: Constraints.mkQual will do extra stuff like generalizing the sorts... mkQual :: BindEnv -> F.Expr -> [ F.Qualifier ]-mkQual env e = case qualParams env e of-  Nothing  -> []-  Just xts -> [ mkScrapeQual xts' e | xts' <- shiftCycle xts ]+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 (F.subst su e) (F.dummyPos "")+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)]]@@ -221,15 +210,11 @@   2. Permute the args?  -} -qualParams :: BindEnv -> F.Expr -> Maybe [(F.Symbol, F.Sort)]-qualParams env e = do-    let xs = Misc.nubOrd (F.syms e)-    ixts <- forM xs $ \x -> do-              (t, i) <- lookupBindEnv x env-              return (i, x, t)-    return [ (x, t) | (_, x, t) <- L.sortBy (comparing Down) ixts ]--    -- ixts = [ (i, x, t) | x <- xs, (i, t) <- lookupBindEnv x env ]+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) ]  ------------------------------------------------------------------------------- 

@@ -84,7 +84,6 @@   where     body =  H.CAnd <$> (reserved "and"    *> many hCstrP)         <|> H.All  <$> (reserved "forall" *> hBindP)      <*> hCstrP-        <|> H.Any  <$> (reserved "exists" *> hBindP)      <*> hCstrP         <|> H.Head <$> (reserved "tag"    *> hPredP)      <*> (H.Tag <$> stringLiteral)         <|> H.Head <$> hPredP                             <*> pure H.NoTag @@ -98,7 +97,7 @@ ------------------------------------------------------------------------------- hPredP = parens body   where-    body =  H.Var  <$> kvSymP                           <*> some symbolP+    body =  H.Var  <$> kvSymP                           <*> some predP         <|> H.PAnd <$> (reserved "and" *> some hPredP)         <|> H.Reft <$> predP 

@@ -187,7 +187,6 @@   where     body =  H.CAnd <$> (reserved "and"    *> many hCstrP)         <|> H.All  <$> (reserved "forall" *> hBindP)  <*> hCstrP-        <|> H.Any  <$> (reserved "exists" *> hBindP)  <*> hCstrP         <|> H.Head <$> (reserved "tag"    *> hPredP)  <*> (H.Tag <$> stringLiteral)  hBindP :: FParser (H.Bind H.Tag)@@ -200,7 +199,7 @@ ------------------------------------------------------------------------------- hPredP = parens body   where-    body =  H.Var  <$> kvSymP <*> some symbolP+    body =  H.Var  <$> kvSymP <*> some exprP         <|> H.PAnd <$> (reserved "and" *> some hPredP)         <|> H.Reft <$> exprP @@ -260,6 +259,16 @@ 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@@ -285,6 +294,7 @@      <|> 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])@@ -304,6 +314,7 @@ 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))@@ -335,7 +346,7 @@  <|> (sym "-"   >> return F.Minus)  <|> (sym "*"   >> return F.Times)  <|> (sym "/"   >> return F.Div)- <|> (sym "mod" >> return F.Mod)+ <|> (reserved "mod" >> return F.Mod)  <|> (sym "*."  >> return F.RTimes)  <|> (sym "/."  >> return F.RDiv) 

@@ -30,9 +30,9 @@ ---------------------------------------------------------------------------------- solveHorn :: F.Config -> IO ExitCode -----------------------------------------------------------------------------------solveHorn baseCfg = do-  q <- parseQuery baseCfg-+solveHorn baseCfg0 = do+  q <- parseQuery baseCfg0+  let baseCfg = baseCfg0 { F.explicitKvars = True }   -- 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 }@@ -67,12 +67,12 @@   saveHornSMT2 cfg q   saveHornJSON cfg q -saveHornSMT2 :: H.ToHornSMT a => F.Config -> a -> IO ()+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.pprint -} H.toHornSMT q)+  writeFile hq $ render (F.toHornSMT q)  saveHornJSON :: F.Config -> H.Query H.Tag -> IO () saveHornJSON cfg q = do

@@ -147,10 +147,12 @@       (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 xs `S.difference` S.singleton n], Just c')+      | k == k' = ([n], [S.toList $ S.fromList (expectVar <$> 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)@@ -160,6 +162,10 @@       [] -> 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) @@ -194,7 +200,6 @@           (eqs' <> eqs'', newVisited')     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@@ -248,16 +253,7 @@     go _ (Head c l) = Head c l     go xs (CAnd c)   = CAnd (go xs <$> c)     go xs (All b c2) = All b $ go (bSym b : xs) c2-    go xs (Any b@(Bind x t p ann) c2) = CAnd [All b' $ CAnd [Head p l, go (x:xs) c2], Any b (Head pi' l)]-      -- TODO: actually use the renamer?-      where-        b' = Bind x t pi' ann-        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 @@ -332,7 +328,6 @@   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)@@ -407,8 +402,6 @@   = CAnd $ applyPi k bp <$> cs applyPi k bp (All b c)   = All b (applyPi k bp c)-applyPi k bp (Any b c)-  = Any b (applyPi k bp c) applyPi k defCstr (Head (Var k' _xs) a)   | k == k'   -- what happens when pi's appear inside the defs for other pis?@@ -475,18 +468,16 @@   = 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 (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) (F.Su $ M.fromList su)-  where su = zip (kargs k) (F.EVar <$> xs)+  where su = zip (kargs k) xs predToExpr (PAnd ps) = F.PAnd $ predToExpr <$> ps  ------------------------------------------------------------------------------@@ -573,7 +564,6 @@   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-  foldE v ctx (Any (Bind x t p l) c) = All <$> (Bind x t <$> foldE v ctx p <*> pure l) <*> foldE v ctx c  ------------------------------------------------------------------------------ -- | Quantifier elimination for use with implicit solver@@ -700,27 +690,7 @@ substPiSols piSols (All (Bind x t p l) c)   | Var k _ <- p = All (Bind x t (M.lookupDefault p k piSols) l) (substPiSols piSols c)   | otherwise = All (Bind x t p l) (substPiSols piSols c)-substPiSols piSols (Any (Bind n _ p _) c)-  | Head (Var pi' _) label <- c, Just sol <- M.lookup pi' piSols =-    case findSol n sol of-      Just e -> Head (flatten $ PAnd $ (\predFn -> F.subst1 predFn (n, e)) <$> [p, sol]) label-      Nothing -> Head (Reft $ F.PAnd []) label-  | otherwise = error "missing piSol" -findSol :: F.Symbol -> Pred -> Maybe F.Expr-findSol sym = 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 == sym = Just right-      | F.EVar y <- right, y == sym = Just left-    findEq _ = Nothing- ------------------------------------------------------------------------------ -- | uniq makes sure each binder has a unique name ------------------------------------------------------------------------------@@ -737,11 +707,6 @@     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@@ -764,18 +729,17 @@  rename :: Pred -> RenameMap -> Pred rename e m = substPred (M.mapMaybeWithKey (\k v -> case v of-                                              (_, n:_) -> Just $ numSym k n+                                              (_, n:_) -> Just $ F.EVar $ 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.Symbol -> Pred -> Pred-substPred su (Reft e) = Reft $ F.subst (F.Su $ F.EVar <$> su) e+substPred :: M.HashMap F.Symbol F.Expr -> Pred -> Pred+substPred su (Reft e) = Reft $ F.subst (F.Su su) e substPred su (PAnd ps) = PAnd $ substPred su <$> ps-substPred su (Var k xs) = Var k $ upd <$> xs-  where upd x = M.lookupDefault x x su+substPred su (Var k xs) = Var k $ F.subst (F.Su su) <$> xs  ------------------------------------------------------------------------------ -- | elim solves all of the KVars in a Cstr (assuming no cycles...)@@ -814,8 +778,6 @@     go (Head _ l) = Left l     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@@ -850,10 +812,9 @@ sol1 k (CAnd cs) = sol1 k =<< cs sol1 k (All b c) = first (b :) <$> sol1 k c sol1 k (Head (Var k' ys) _) | k == k'-  = [([], zipWith (F.PAtom F.Eq) (F.EVar <$> xs) (F.EVar <$> ys))]+  = [([], zipWith (F.PAtom F.Eq) (F.EVar <$> xs) 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 ..]@@ -871,9 +832,9 @@     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   where-    demorgan :: F.Symbol -> F.Sort -> a -> [(F.Symbol, [F.Symbol])] -> [Pred] -> Cstr a -> [([Bind a], [F.Expr])] -> Cstr a+    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) (F.EVar <$> xs)) kvars+      where su = F.Su $ M.fromList $ concatMap (\(k, xs) -> zip (kargs k) xs) kvars             mkAnd [c] = c             mkAnd cs = CAnd cs             cubeSol (b:bs, eqs) = All b $ cubeSol (bs, eqs)@@ -883,14 +844,9 @@   = Head (Reft F.PTrue) a doelim _ _ (Head p a) = Head p a -doelim k bss (Any (Bind x t p l) c) =-  case findKVarInGuard k p of-    Right _ -> Any (Bind x t p l) (doelim k bss c)-    Left (_, rights') -> Any (Bind x t (PAnd rights') l) (doelim k bss c) -- TODO: for now we set the kvar to true. not sure if this is correct- -- If k is in the guard then returns a Left list of that k and the remaining preds in the guard -- If k is not in the guard returns a Right of the pred-findKVarInGuard :: F.Symbol -> Pred -> Either ([(F.Symbol, [F.Symbol])], [Pred]) Pred+findKVarInGuard :: F.Symbol -> Pred -> Either ([(F.Symbol, [F.Expr])], [Pred]) Pred findKVarInGuard k (PAnd ps) =   if null lefts     then Right (PAnd ps) -- kvar not found@@ -923,7 +879,6 @@ boundKvars (Head p _)           = pKVars p boundKvars (CAnd c)             = mconcat $ boundKvars <$> c boundKvars (All (Bind _ _ p _) c) = pKVars p <> boundKvars c-boundKvars (Any (Bind _ _ p _) c) = pKVars p <> boundKvars c  pKVars :: Pred -> S.Set F.Symbol pKVars (Var k _) = S.singleton k@@ -935,7 +890,6 @@ 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@@ -949,7 +903,6 @@ forgetPiVars pis (All (Bind x t p l) c)   | Var k _ <- p, k `S.member` pis = All (Bind x t (PAnd []) l) $ forgetPiVars pis c   | otherwise = All (Bind x t p l) $ forgetPiVars pis c-forgetPiVars _ Any{} = error "shouldn't be present"  ----------------------------------------------------------------------------------- -- | Cleanup Horn Constraint@@ -997,7 +950,6 @@     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-    go (Any (Bind x t p l) c) = Any (Bind x t (flatten p) l) <$> go c      mk []  = Nothing     mk [c] = Just c@@ -1062,7 +1014,6 @@         splitP 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@@ -1071,7 +1022,6 @@     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 (Any b c) = Any b $ go xs c  pruneTauts :: Cstr a -> Cstr a pruneTauts = fromMaybe (CAnd []) . go@@ -1084,7 +1034,6 @@     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

@@ -10,7 +10,6 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ViewPatterns #-}  module Language.Fixpoint.Horn.Types   ( -- * Horn Constraints and their components@@ -34,8 +33,6 @@     -- * extract qualifiers   , quals -    -- * SMTLIB style render-  , ToHornSMT (..)   )   where @@ -63,19 +60,27 @@   }   deriving (Eq, Ord, Data, Typeable, Generic, Functor, ToJSON, FromJSON) ++ ------------------------------------------------------------------------------- -- | @HPred@ is a Horn predicate that appears as LHS (body) or RHS (head) of constraints ------------------------------------------------------------------------------- data Pred   = Reft  !F.Expr                               -- ^ r-  | Var   !F.Symbol ![F.Symbol]                 -- ^ $k(y1..yn)+  | Var   !F.Symbol ![F.Expr]                   -- ^ $k(y1..yn)   | PAnd  ![Pred]                               -- ^ p1 /\ .../\ pn   deriving (Data, Typeable, Generic, Eq, ToJSON, FromJSON) +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 F.Subable Pred where   syms (Reft e)   = F.syms e-  syms (Var _ xs) = xs+  syms (Var _ xs) = concatMap F.syms xs   syms (PAnd ps)  = concatMap F.syms ps    substa f (Reft e)   = Reft  (F.substa f      e)@@ -105,7 +110,6 @@     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 _ (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@@ -155,6 +159,9 @@   }   deriving (Data, Typeable, Generic, Functor, Eq, ToJSON, FromJSON) +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 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@@ -167,9 +174,17 @@   = Head  !Pred !a                  -- ^ p   | CAnd  ![Cstr a]                 -- ^ c1 /\ ... /\ cn   | All   !(Bind a)  !(Cstr a)      -- ^ \all x:t. p => c-  | Any   !(Bind a)  !(Cstr a)      -- ^ \exi x:t. p /\ c or is it \exi x:t. p => c?   deriving (Data, Typeable, Generic, Functor, Eq, 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)])+ cLabel :: Cstr a -> a cLabel cstr = case go cstr of   [] -> F.panic "everything is true!!!"@@ -178,13 +193,11 @@     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 Any {} = True okCstr _      = False  @@ -236,7 +249,9 @@   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   @@ -284,13 +299,12 @@  instance Show Pred where   show (Reft p)   = parens $ F.showpp p-  show (Var x xs) = parens $ "$" ++ unwords (F.symbolString <$> x:xs)+  show (Var x xs) = parens $ "$" ++ unwords (F.symbolString x : (parens . F.showpp <$> 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@@ -301,7 +315,7 @@  instance F.PPrint Pred where   pprintPrec k t (Reft p)   = P.parens $ F.pprintPrec k t p-  pprintPrec _ _ (Var x xs) = P.parens $ P.ptext "$" <> P.hsep (P.ptext . F.symbolString <$> x:xs)+  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 k t (PAnd ps)  = P.parens $ P.vcat $ P.ptext "and" : map (F.pprintPrec (k+2) t) ps  instance F.PPrint (Cstr a) where@@ -309,170 +323,25 @@   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   pprintPrec _ _ b = P.ptext $ show b ---------------------------------------------------------------------------------------------------------------------- Human readable but robustly parseable SMT-LIB format pretty printer-------------------------------------------------------------------------------------------------------------------class ToHornSMT a where-  toHornSMT :: a -> P.Doc--instance ToHornSMT Tag where-  toHornSMT NoTag   = mempty-  toHornSMT (Tag s) = P.text s--instance ToHornSMT F.Symbol where-  toHornSMT s = F.pprint s--instance ToHornSMT (Var a) where-  toHornSMT (HVar k ts _) = P.parens ("var" P.<+> "$" P.<-> F.pprint k P.<+> toHornSMT ts)--instance ToHornSMT (Query a) where+instance F.ToHornSMT (Query a) where   toHornSMT q = P.vcat $ L.intersperse " "     [ P.vcat   (toHornOpt <$> qOpts q)     , P.vcat   (toHornNum <$> qNums q)-    , P.vcat   (toHornSMT <$> qQuals q)-    , P.vcat   (toHornSMT <$> qVars 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   (eqnToHornSMT "define"     <$> qEqns q)-    , P.vcat   (eqnToHornSMT "define_fun" <$> qDefs q)-    , P.vcat   (toHornSMT <$> qData q)-    , P.vcat   (toHornSMT <$> qMats q)-    , P.parens (P.vcat ["constraint", P.nest 1 (toHornSMT (qCstr 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   = toHornMany ["numeric", toHornSMT x]-      toHornOpt str = toHornMany ["fixpoint", P.text ("\"" ++ str ++ "\"")]-      toHornCon x t = toHornMany ["constant", toHornSMT x, toHornSMT t]--instance ToHornSMT F.Rewrite where-  toHornSMT (F.SMeasure f d xs e) =  P.parens ("match" P.<+> toHornSMT f P.<+> toHornSMT (d:xs) P.<+> toHornSMT e)--instance ToHornSMT F.Qualifier where-  toHornSMT (F.Q n xts p _) =  P.parens ("qualif" P.<+> F.pprint n P.<+> toHornSMT xts P.<+> toHornSMT p)--instance ToHornSMT F.QualParam where-  toHornSMT qp = toHornSMT (F.qpSym qp, F.qpSort qp)--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 -- Misc.intersperse " "--toHornAnd :: (a -> P.Doc) -> [a] -> P.Doc-toHornAnd f xs = P.parens (P.vcat ("and" : (P.nest 1 . f <$> xs)))--eqnToHornSMT :: P.Doc -> F.Equation -> P.Doc-eqnToHornSMT keyword (F.Equ f xs e s _) = P.parens (keyword P.<+> F.pprint f P.<+> toHornSMT xs P.<+> toHornSMT s P.<+> toHornSMT e)---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)--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 (Bind a) where-  toHornSMT (Bind x t p _) = P.parens (toHornSMT (x, t) P.<+> toHornSMT p)--instance ToHornSMT Pred where-  toHornSMT (Reft p)   = P.parens (toHornSMT p)-  toHornSMT (Var k xs) = toHornMany (toHornSMT (F.KV k) : (toHornSMT <$> xs))-  toHornSMT (PAnd ps)  = toHornMany ("and" : (toHornSMT <$> ps))--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.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]-toHornExpr (F.PGrad k _ _ e) = toHornMany ["&&", toHornSMT e, toHornSMT k]--toHornOp :: ToHornSMT a => P.Doc -> [a] -> P.Doc-toHornOp op es = toHornMany (op : (toHornSMT <$> es))--instance ToHornSMT (Cstr a) where-  toHornSMT = toHornCstr--toHornCstr :: Cstr a -> P.Doc-toHornCstr (Head p _) = toHornSMT p-toHornCstr (CAnd cs)  = toHornAnd toHornCstr cs-toHornCstr (All b c)  = P.parens (P.vcat ["forall" P.<+> toHornSMT b-                                         , P.nest 1 (toHornCstr c)])-toHornCstr (Any b c)  = P.parens (P.vcat ["exists" P.<+> toHornSMT b-                                         , P.nest 1 (toHornCstr c)])+      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]

@@ -21,6 +21,11 @@ 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]

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                       #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -92,6 +91,7 @@    -- * Parsing Function   , doParse'+  , doParse''   , parseTest'   , parseFromFile   , parseFromStdIn@@ -123,9 +123,7 @@ import qualified Data.IntMap.Strict          as IM import qualified Data.HashMap.Strict         as M import qualified Data.HashSet                as S-#if !MIN_VERSION_base(4,20,0)-import           Data.List                   (foldl')-#endif+import qualified Data.List                   as List import           Data.List.NonEmpty          (NonEmpty(..)) import qualified Data.Text                   as T import qualified Data.Text.IO                as T@@ -231,6 +229,7 @@                      , supply      :: !Integer                      , layoutStack :: LayoutStack                      , numTyCons   :: !(S.HashSet Symbol)+                     , allowExists :: !Bool                      } type PState = PStateV Symbol @@ -476,6 +475,7 @@   , "func"   , "autorewrite"   , "rewrite"+  , "lit"    -- reserved words used in liquid haskell   , "forall"@@ -537,7 +537,7 @@   , "->"   , ":="   , "&", "^", "<<", ">>", "--"-  , "?", "Bexp"+  , "Bexp"   , "'"   , "_|_"   , "|"@@ -677,7 +677,7 @@ -- * 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 = do+condIdR initial okChars condition msg = try $ do   s <- (:) <$> initial <*> takeWhileP Nothing okChars   if condition s     then pure (symbol s)@@ -789,28 +789,17 @@ -- This parser is reused by Liquid Haskell. -- expr0P :: ParseableV v => ParserV v (ExprV v)-expr0P-  =  trueP -- constant "true"- <|> falseP -- constant "false"- <|> (reservedOp "?" *> predP)- <|> 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 <$> 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 "["- --- -- 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 ...+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  emptyListP :: Located () -> ParserV v (ExprV v) emptyListP lx = do@@ -836,7 +825,7 @@ fastIfP :: ParseableV v => (ExprV v -> a -> a -> a) -> ParserV v a -> ParserV v a fastIfP f bodyP   = do reserved "if"-       p <- predP+       p <- exprP        reserved "then"        b1 <- bodyP        reserved "else"@@ -848,35 +837,12 @@   (s, t) <- parens (pairP sortP (reservedOp "~") sortP)   ECoerc s t <$> p ---{--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 :: ParseableV v => ParserV v (ExprV v)-expr1P-  =  try funAppP- <|> expr0P- -- | Expressions  exprP :: ParseableV v => ParserV v (ExprV v)-exprP =-  do+exprP = do     table <- gets fixityTable-    makeExprParser expr1P (flattenOpTable table)+    makeExprParser expr0P (flattenOpTable table)  data Assoc = AssocNone | AssocLeft | AssocRight @@ -968,7 +934,7 @@  -- | Built-in operator table, parameterised over the composition function. bops :: forall v. ParseableV v => Maybe (Located String -> ExprV v) -> OpTable v-bops cmpFun = foldl' (flip addOperator) initOpTable builtinOps+bops cmpFun = List.foldl' (flip addOperator) initOpTable builtinOps   where     -- Built-in Haskell operators, see https://www.haskell.org/onlinereport/decls.html#fixity     builtinOps :: [Fixity v]@@ -980,37 +946,55 @@                  , FInfix  (Just 5) "mod" (Just $ const $ EBin Mod)   AssocLeft -- Haskell gives mod 7                  , FInfix  (Just 9) "."   applyCompose        AssocRight                 --  ---                --  , FInfix  (Just 4) "<"   (Just $ PAtom Lt)  AssocNone-                --  , FInfix  (Just 4) "=="  (Just $ PAtom Eq)  AssocNone-                --  , FInfix  (Just 4) "="   (Just $ PAtom Eq)  AssocNone-                --  , FInfix  (Just 4) "~~"  (Just $ PAtom Ueq) AssocNone-                --  , FInfix  (Just 4) "!="  (Just $ PAtom Ne)  AssocNone-                --  , FInfix  (Just 4) "/="  (Just $ PAtom Ne)  AssocNone-                --  , FInfix  (Just 4) "!~"  (Just $ PAtom Une) AssocNone-                --  , FInfix  (Just 4) "<"   (Just $ PAtom Lt)  AssocNone-                --  , FInfix  (Just 4) "<="  (Just $ PAtom Le)  AssocNone-                --  , FInfix  (Just 4) ">"   (Just $ PAtom Gt)  AssocNone-                --  , FInfix  (Just 4) ">="  (Just $ PAtom Ge)  AssocNone+                 , 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  -- | Parser for function applications.------ Andres, TODO: Why is this so complicated?--- funAppP :: ParseableV v => ParserV v (ExprV v)-funAppP      =  litP <|> exprFunP <|> simpleAppP-  where-    exprFunP = eApps <$> funSymbolP <*> funRhsP-    funRhsP  =  some expr0P-            <|> parens innerP-    innerP   = brackets (sepBy exprP semi)+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 -    -- TODO:AZ the parens here should be superfluous, but it hits an infinite loop if removed-    simpleAppP     = EApp <$> parens exprP <*> parens exprP-    funSymbolP     = EVar <$> parseV+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 +-- | constant bottom, equivalent to "false"+botP :: ParserV v (ExprV v)+botP = reservedOp "_|_" >> return EBot+ -- | Parser for tuple expressions (two or more components). tupleP :: ParseableV v => ParserV v (ExprV v) tupleP = do@@ -1035,9 +1019,10 @@        t <- sortP        reservedOp "->"        ELam (x, t) <$> exprP+      <?> "lambda abstraction"  varSortP :: ParserV v Sort-varSortP  = FVar  <$> parens intP+varSortP  = FVar  <$> parens (fromInteger <$> integerP)  -- | Parser for function sorts without the "func" keyword. funcSortP :: ParserV v Sort@@ -1072,6 +1057,7 @@   <|> (fAppTC listFTyCon . pure <$> brackets sortP)   <|> (fAppTC <$> fTyConP <*> appArgsP)   <|> (fApp   <$> tvarP   <*> appArgsP)+  <|> (FNatNum <$> natural)  tvarP :: ParserV v Sort tvarP@@ -1100,31 +1086,6 @@ -- | Predicates ---------------------------------------------------------------- -------------------------------------------------------------------------------- --- | Parser for "atomic" predicates.------ This parser is reused by Liquid Haskell.----pred0P :: ParseableV v => ParserV v (ExprV v)-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 <$> parseV -- identifier, starts with any letter or underscore-      <|> (reservedOp "&&" >> pGAnds <$> predsP) -- built-in prefix and-      <|> (reservedOp "||" >> POr  <$> predsP) -- built-in prefix or--makeUniquePGrad :: ParserV v (ExprV v)-makeUniquePGrad-  = do uniquePos <- getSourcePos-       return $ PGrad (KV $ symbol $ show uniquePos) (Su mempty) (srcGradInfo uniquePos) PTrue---- qmP    = reserved "?" <|> reserved "Bexp"- -- | Parser for the reserved constant "true". trueP :: ParserV v (ExprV v) trueP  = reserved "true"  >> return PTrue@@ -1150,53 +1111,23 @@ -- disjunction. -- predsP :: ParseableV v => ParserV v [ExprV v]-predsP = brackets $ sepBy predP semi+predsP = brackets $ sepBy exprP semi  -- | Parses a predicate. ----- Unlike for expressions, there is a built-in operator list.--- predP  :: ParseableV v => ParserV v (ExprV v)-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)]-           , [InfixR (reservedOp "!="   >> return pNotIff)]-           , [InfixR (reservedOp "/="   >> return pNotIff)]-           ]--pNotIff :: ExprV v -> ExprV v -> ExprV v-pNotIff x y = PNot (PIff x y)---- | Parses a relation predicate.------ Binary relations connect expressions and predicates.----predrP :: ParseableV v => ParserV v (ExprV v)-predrP =-  (\ e1 r e2 -> r e1 e2) <$> exprP <*> brelP <*> exprP+predP  = exprP --- | Parses a relation symbol.------ There is a built-in table of available relations.----brelP ::  ParserV v (ExprV v -> ExprV v -> ExprV v)-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))+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  -------------------------------------------------------------------------------- -- | BareTypes -----------------------------------------------------------------@@ -1204,8 +1135,8 @@  -- | Refa refaP :: ParseableV v => ParserV v (ExprV v)-refaP =  try (pAnd <$> brackets (sepBy predP semi))-     <|> predP+refaP =  try (PAnd <$> brackets (sepBy exprP semi))+     <|> exprP   -- | (Sorted) Refinements with configurable sub-parsers@@ -1260,8 +1191,7 @@   pos    <- getSourcePos   n      <- upperIdP   params <- parens $ sepBy1 (qualParamP tP) comma-  _      <- colon-  body   <- predP+  body   <- braces exprP   return  $ mkQual n params body pos  qualParamP :: ParserV v Sort -> ParserV v QualParam@@ -1302,8 +1232,10 @@   _          <- spaces   _          <- reserved "="   _          <- spaces-  (lhs, rhs) <- braces $-      pairP exprP (reserved "=") exprP+  e <- braces exprP+  (lhs, rhs) <- case e of+                  PAtom Eq l r -> return (l, r)+                  _ -> error "Expected rewrite rule of the form: LHS = RHS"   return $ AutoRewrite args lhs rhs  @@ -1312,9 +1244,7 @@   name   <- symbolP   params <- parens        $ sepBy (symBindP sortP) comma   sort   <- colon        *> sortP-  body   <- reserved "=" *> braces (-              if sort == boolSort then predP else exprP-               )+  body   <- reserved "=" *> braces exprP   return  $ mkEquation name params body sort  defineLocalP :: Parser (Int, [(Symbol, Expr)])@@ -1331,7 +1261,7 @@         return (x, e)  matchP :: Parser Rewrite-matchP = SMeasure <$> symbolP <*> symbolP <*> many symbolP <*> (reserved "=" >> exprP)+matchP = SMeasure <$> symbolP <*> symbolP <*> many symbolP <*> braces exprP  pairsP :: Parser a -> Parser b -> Parser [(a, b)] pairsP aP bP = brackets $ sepBy (pairP aP (reserved ":") bP) semi@@ -1444,20 +1374,23 @@ intP :: ParserV v 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 ebs lts dts kts qs binfo adts mempty mempty ae lrws mempty+defsFInfo defs = {- SCC "defsFI" -} Types.FI cm ws bs lts dts kts qs binfo adts mempty mempty ae lrws mempty   where     cm         = Misc.safeFromList                    "defs-cm"        [(cid c, c)         | Cst c       <- defs]     ws         = Misc.safeFromList                    "defs-ws"        [(i, w)              | Wfc w    <- defs, let i = Misc.thd3 (wrft w)]-    bs         = bindEnvFromList  $ exBinds ++ [(n,(x,r,a)) | IBind n x r a <- defs]-    ebs        =                    [ n                  | (n,_) <- exBinds]-    exBinds    =                    [(n, (x, RR t trueReft, a)) | EBind n x t a <- defs]+    bs         = bindEnvFromList    [(n,(x,r,a)) | IBind n x r a <- defs]     lts        = fromListSEnv       [(x, t)             | Con x t     <- defs]     dts        = fromListSEnv       [(x, t)             | Dis x t     <- defs]     kts        = KS $ S.fromList    [k                  | Kut k       <- defs]@@ -1468,7 +1401,7 @@     rews       =                    [r                  | Mat r       <- defs]     autoRWs    = M.fromList         [(arId , s)         | AutoRW arId s <- defs]     rwEntries  =                    [(i, f)             | RWMap fs   <- defs, (i,f) <- fs]-    rwMap      = foldl' insert (M.fromList []) rwEntries+    rwMap      = List.foldl' insert (M.fromList []) rwEntries                  where                    insert map' (cid', arId) =                      case M.lookup arId autoRWs of@@ -1498,28 +1431,6 @@   msg <- takeWhileP Nothing (const True) -- consume the rest of the input   return $ Crash [(i, Nothing)] 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@@ -1547,6 +1458,7 @@                            , supply      = 0                            , layoutStack = Empty                            , numTyCons   = S.empty+                           , allowExists = False                            }  -- | Entry point for parsing, for testing.@@ -1555,8 +1467,11 @@ -- Fails with an exception on a parse error. -- doParse' :: Parser a -> SourceName -> String -> a-doParse' parser fileName input =-  case runParser (evalStateT (spaces *> parser <* eof) (initPState Nothing)) fileName input of+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     Left peb@(ParseErrorBundle errors posState) -> -- parse errors; we extract the first error from the error bundle       let         ((_, pos) :| _, _) = attachSourcePos errorOffset errors posState@@ -1600,7 +1515,7 @@  <|> (reserved "push"     >> return Push)  <|> (reserved "pop"      >> return Pop)  <|> (reserved "check"    >> return CheckSat)- <|> (reserved "assert"   >> (Assert Nothing <$> predP))+ <|> (reserved "assert"   >> (Assert Nothing <$> exprP))  <|> (reserved "distinct" >> (Distinct <$> brackets (sepBy exprP comma)))  cmdVarP :: Parser Command@@ -1632,9 +1547,6 @@ 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 @@ -1647,100 +1559,3 @@ 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)--}

@@ -45,13 +45,14 @@     , smtDecls     , smtDefineFunc     , smtAssert+    , smtAssertDecl     , smtFuncDecl     , smtAssertAxiom     , smtCheckUnsat-    , smtCheckSat     , smtBracket, smtBracketAt     , smtDistinct     , smtPush, smtPop+    , smtComment      -- * Check Validity     , checkValid@@ -59,10 +60,12 @@     , checkValidWithContext     , checkValids +    , funcSortVars+     ) where  import           Language.Fixpoint.Types.Config ( SMTSolver (..), solverFlags-                                                , Config (solver, smtTimeout, gradual, stringTheory, save))+                                                , Config (solver, smtTimeout, noStringTheory, save, allowHO)) import qualified Language.Fixpoint.Misc          as Misc import           Language.Fixpoint.Types.Errors import           Language.Fixpoint.Utils.Files@@ -73,6 +76,7 @@ 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@@ -80,6 +84,7 @@ 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) import qualified Data.Text                as T import qualified Data.Text.Encoding       as TE@@ -102,6 +107,7 @@ 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@@ -117,36 +123,43 @@        return zs -} -checkValidWithContext :: Context -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool-checkValidWithContext me xts p q =-  smtBracket me "checkValidWithContext" $-    checkValid' me xts p q+checkValidWithContext+  :: HasCallStack => [(Symbol, Sort)] -> Expr -> Expr -> SmtM Bool+checkValidWithContext xts p q =+  smtBracket "checkValidWithContext" $+    checkValid' xts p q  -- | type ClosedPred E = {v:Pred | subset (vars v) (keys E) } -- checkValid :: e:Env -> ClosedPred e -> ClosedPred e -> IO Bool-checkValid :: Config -> FilePath -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool+checkValid+  :: HasCallStack+  => Config -> FilePath -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool checkValid cfg f xts p q = do   me <- makeContext cfg f-  checkValid' me xts p q+  evalStateT (checkValid' xts p q) me -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+checkValid' :: HasCallStack => [(Symbol, Sort)] -> Expr -> Expr -> SmtM Bool+checkValid' xts p q = do+  smtDecls xts+  smtAssertDecl $ pAnd [p, PNot q]+  smtCheckUnsat  -- | 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-       smtDecls me xts-       forM ps $ \p ->-          smtBracket me "checkValids" $-            smtAssert me (PNot p) >> smtCheckUnsat me+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+ -- debugFile :: FilePath -- debugFile = "DEBUG.smt2" @@ -154,42 +167,55 @@ -- | 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              :: Context -> Command -> IO Response+command  :: HasCallStack => Command -> SmtM Response ---------------------------------------------------------------------------------command Ctx{..} !cmd       = do+command !cmd       = do   -- whenLoud $ do LTIO.appendFile debugFile (s <> "\n")   --               LTIO.putStrLn ("CMD-RAW:" <> s <> ":CMD-RAW:DONE")-  forM_ ctxLog $ \h -> do+  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"-  case cmd of-    CheckSat   -> commandRaw-    GetValue _ -> commandRaw+  lift $ case cmd of+    CheckSat   -> commandRaw ctxLog ctxSolver ctxVerbose cmdBS+    GetValue _ -> commandRaw ctxLog ctxSolver ctxVerbose cmdBS     _          -> SMTLIB.Backends.command_ ctxSolver cmdBS >> return Ok-  where-    commandRaw      = do-      resp <- SMTLIB.Backends.command ctxSolver cmdBS-      let respTxt =-            TE.decodeUtf8With (const $ const $ Just ' ') $-            LBS.toStrict resp-      parse respTxt-    cmdBS = {-# SCC "Command-runSmt2" #-} runSmt2 ctxSymEnv cmd-    parse resp      = do-      case A.parseOnly responseP resp 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 -smtSetMbqi :: Context -> IO ()-smtSetMbqi me = interact' me SetMbqi+-- | 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 +smtSetMbqi :: SmtM ()+smtSetMbqi = interact' SetMbqi+ type SmtParser a = Parser T.Text a  responseP :: SmtParser Response@@ -254,12 +280,11 @@     where        smtFile = extFileName Smt2 f -makeContextWithSEnv :: Config -> FilePath -> SymEnv -> [Equation] -> IO Context+makeContextWithSEnv :: Config -> FilePath -> SymEnv -> DefinedFuns -> IO Context makeContextWithSEnv cfg f env defns = do-  ctx     <- makeContext cfg f+  ctx      <- makeContext cfg f   let ctx' = ctx {ctxSymEnv = env, ctxDefines = defns}-  declare ctx'-  return ctx'+  execStateT declare ctx'  makeContextNoLog :: Config -> IO Context makeContextNoLog cfg = do@@ -307,16 +332,22 @@          Cvc5    -> makeProcess ctxLog $                       Process.defaultConfig                              { Process.exe = "cvc5"-                             , Process.args = ["-L", "smtlib2"] }+                             , Process.args = ["-L", "smtlib2", "--arrays-exp"] }        solver <- SMTLIB.Backends.initSolver SMTLIB.Backends.Queuing backend        loud <- isLoud        return Ctx { ctxSolver    = solver-                  , ctxElabF     = solverFlags slv+                  , 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                   }  -- | Close file handles and release the solver backend's resources.@@ -333,9 +364,11 @@   | s == Z3 || s == Z3mem     = do v <- getZ3Version me          checkValidStringFlag Z3 v cfg-         return $ makeMbqi cfg ++ makeTimeout cfg ++ Thy.preamble cfg Z3+         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)"]  getZ3Version :: Context -> IO [Int] getZ3Version me@@ -361,58 +394,59 @@  noString :: SMTSolver -> [Int] -> Config -> Bool noString smt v cfg-  =  stringTheory cfg-  && not (smt == Z3 && (v >= [4, 4, 2]))-+  =  not (noStringTheory cfg)+  && not (smt == Cvc5 || (smt == Z3 && (v >= [4, 4, 2]))) ----------------------------------------------------------------------------- -- | SMT Commands ----------------------------------------------------------- ----------------------------------------------------------------------------- -smtPush, smtPop   :: Context -> IO ()-smtPush me        = interact' me Push-smtPop me         = interact' me Pop+smtPush, smtPop :: SmtM ()+smtPush = interact' Push+smtPop  = interact' Pop -smtDecls :: Context -> [(Symbol, Sort)] -> IO ()-smtDecls = mapM_ . uncurry . smtDecl+smtComment :: T.Text -> SmtM ()+smtComment t = interact' (Comment t) -smtDecl :: Context -> Symbol -> Sort -> IO ()-smtDecl me x t = interact' me ({- notracepp msg $ -} Declare (symbolSafeText x) ins' out')+smtDecls :: [(Symbol, Sort)] -> SmtM ()+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')   where-    ins'       = sortSmtSort False env <$> ins-    out'       = sortSmtSort False env     out     (ins, out) = deconSort t-    _msg        = "smtDecl: " ++ showpp (x, t, ins, out)-    env        = seData (ctxSymEnv me)+    _msg       = "smtDecl: " ++ showpp (x, t, ins, out) -smtFuncDecl :: Context -> T.Text -> ([SmtSort],  SmtSort) -> IO ()-smtFuncDecl me x (ts, t) = interact' me (Declare x ts t)+smtFuncDecl :: T.Text -> ([SmtSort],  SmtSort) -> SmtM ()+smtFuncDecl x (ts, t) = interact' (Declare x ts t) -smtDataDecl :: Context -> [DataDecl] -> IO ()-smtDataDecl me ds = interact' me (DeclData ds)+smtDataDecl :: [DataDecl] -> SmtM ()+smtDataDecl ds = interact' (DeclData ds)  deconSort :: Sort -> ([Sort], Sort) deconSort t = case functionSort t of                 Just (_, ins, out) -> (ins, out)                 Nothing            -> ([], t) --- 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+smtAssert :: Expr -> SmtM ()+smtAssert p = interact' (Assert Nothing p) -smtAssert :: Context -> Expr -> IO ()-smtAssert me p = interact' me (Assert Nothing p)+-- 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) -smtDefineEqn :: Context -> Equation -> IO ()-smtDefineEqn me Equ {..} = smtDefineFunc me eqName eqArgs eqSort eqBody+smtDefineEqn :: Equation -> SmtM ()+smtDefineEqn Equ {..} = smtDefineFunc eqName eqArgs eqSort eqBody -smtDefineFunc :: Context -> Symbol -> [(Symbol, F.Sort)] -> F.Sort -> Expr -> IO ()-smtDefineFunc me name symList rsort e =-  let env = seData (ctxSymEnv me)-  in interact' me $+smtDefineFunc :: Symbol -> [(Symbol, F.Sort)] -> F.Sort -> Expr -> SmtM ()+smtDefineFunc name symList rsort e =+  do env <- gets (seData . ctxSymEnv)+     interactDecl' $         DefineFunc           name           (map (sortSmtSort False env <$>) symList)@@ -421,34 +455,60 @@  ----------------------------------------------------------------- -smtAssertAxiom :: Context -> Triggered Expr -> IO ()-smtAssertAxiom me p  = interact' me (AssertAx p)+smtAssertAxiom :: Triggered Expr -> SmtM ()+smtAssertAxiom p  = interact' (AssertAx p) -smtDistinct :: Context -> [Expr] -> IO ()-smtDistinct me az = interact' me (Distinct az)+smtDistinct :: [Expr] -> SmtM ()+smtDistinct az = interact' (Distinct az) -smtCheckUnsat :: Context -> IO Bool-smtCheckUnsat me  = respSat <$> command me CheckSat+smtCheckUnsat :: HasCallStack => SmtM Bool+smtCheckUnsat = respSat <$> command CheckSat -smtBracketAt :: SrcSpan -> Context -> String -> IO a -> IO a-smtBracketAt sp x y z = smtBracket x y z `catch` dieAt sp+smtBracketAt :: SrcSpan -> String -> SmtM a -> SmtM a+smtBracketAt sp _msg a =+  smtBracket _msg a `catchSMT` dieAt sp -smtBracket :: Context -> String -> IO a -> IO a-smtBracket me _msg a   = do-  smtPush me+-- | `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}   r <- a-  smtPop me+  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}   return r -respSat :: Response -> Bool+respSat :: HasCallStack => Response -> Bool respSat Unsat   = True respSat Sat     = False respSat Unknown = False respSat r       = die $ err dummySpan $ text ("crash: SMTLIB2 respSat = " ++ show r) -interact' :: Context -> Command -> IO ()-interact' me cmd  = void $ command me cmd+interact' :: Command -> SmtM ()+interact' cmd  = void $ command 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 cfg@@ -456,36 +516,28 @@   | otherwise                = [""]  -makeMbqi :: Config -> [Builder]-makeMbqi cfg-  | gradual cfg = [""]-  | otherwise   = ["\n(set-option :smt.mbqi false)"]-- ---------------------------------------------------------------------------------declare :: Context -> IO ()+declare :: SmtM () ---------------------------------------------------------------------------------declare me = do-  forM_ dss    $           smtDataDecl me-  forM_ thyXTs $ uncurry $ smtDecl     me-  forM_ qryXTs $ uncurry $ smtDecl     me-  forM_ ats    $ uncurry $ smtFuncDecl me-  forM_ defs   $           smtDefineEqn 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     =             [ (x, t) | (x, t) <- xts, symKind env x == Just F.Uninterp ]-    qryXTs     = fmap tx <$> [ (x, t) | (x, t) <- xts, symKind env x == Nothing ]-    -- isKind n   = (n ==)  . symKind env . fst-    xts        = symbolSorts (F.seSort env)-    tx         = elaborate (ElabParam (ctxElabF me) "declare" env)-    ats        = funcSortVars env-    defs       = ctxDefines me+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  symbolSorts :: F.SEnv F.Sort -> [(F.Symbol, F.Sort)] symbolSorts env = [(x, tx t) | (x, t) <- F.toListSEnv env ]@@ -496,14 +548,24 @@ dataDeclarations :: SymEnv -> [[DataDecl]] dataDeclarations = orderDeclarations . map snd . F.toListSEnv . F.seData -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] ]+-- | 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   where-    var n         = F.symbolAtSmtName n env ()-    ts            = M.keys (F.seAppls env)+    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+     appSort (s,t) = ([F.SInt, s], t)     lamSort (s,t) = ([s, t], F.SInt)     argSort (s,_) = ([]    , s)

@@ -14,6 +14,7 @@  module Language.Fixpoint.Smt.Serialize (smt2SortMono) where +import           Control.Monad.State import           Data.ByteString.Builder (Builder) import           Language.Fixpoint.SortCheck import           Language.Fixpoint.Types@@ -27,47 +28,65 @@ -- import Debug.Trace (trace)  instance SMTLIB2 (Symbol, Sort) where-  smt2 env c@(sym, t) = -- build "({} {})" (smt2 env sym, smt2SortMono c env t)-                        parenSeqs [smt2 env sym, smt2SortMono c env t]+  smt2 c@(sym, t) =+    -- build "({} {})" (smt2 env sym, smt2SortMono c env t)+    do s <- smt2 sym+       ss <- smt2SortMono c t+       pure $ parenSeqs [s , ss] -smt2SortMono, smt2SortPoly :: (PPrint a) => a -> SymEnv -> Sort -> Builder+instance SMTLIB2 (Symbol, Expr) where+  smt2 (sym, e) =+    do s <- smt2 sym+       ss <- smt2 e+       pure $ parenSeqs [s, ss]++smt2SortMono, smt2SortPoly :: (PPrint a) => a -> Sort -> SymM Builder smt2SortMono = smt2Sort False smt2SortPoly = smt2Sort True -smt2Sort :: (PPrint a) => Bool -> a -> SymEnv -> Sort -> Builder-smt2Sort poly _ env t = smt2 env (Thy.sortSmtSort poly (seData env) t)+smt2Sort :: (PPrint a) => Bool -> a -> Sort -> SymM Builder+smt2Sort poly _ t =+  do env <- get+     smt2 (Thy.sortSmtSort poly (seData env) t) -smt2data :: SymEnv -> [DataDecl] -> Builder-smt2data env = smt2data' env . map padDataDecl+smt2data :: [DataDecl] -> SymM Builder+smt2data = smt2data' . map padDataDecl -smt2data' :: SymEnv -> [DataDecl] -> Builder-smt2data' env ds = seqs [ parens $ smt2many (smt2dataname env <$> ds)-                        , parens $ smt2many (smt2datactors env <$> ds)-                        ]+smt2data' :: [DataDecl] -> SymM Builder+smt2data' ds =+  do n <- traverse smt2dataname ds+     d <- traverse smt2datactors ds+     pure $ seqs [ parens $ smt2many n , parens $ smt2many d ]  -smt2dataname :: SymEnv -> DataDecl -> Builder-smt2dataname env (DDecl tc as _) = parenSeqs [name, n]-  where-    name  = smt2 env (symbol tc)-    n     = smt2 env as+smt2dataname :: DataDecl -> SymM Builder+smt2dataname (DDecl tc as _) =+  do name <- smt2 (symbol tc)+     n    <- smt2 as+     pure $ parenSeqs [name, n]  -smt2datactors :: SymEnv -> DataDecl -> Builder-smt2datactors env (DDecl _ as cs)-  | as > 0       = parenSeqs ["par", parens tvars, parens ds]-  | otherwise    =                                 parens ds+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)   where-    tvars        = smt2many (smt2TV <$> [0..(as-1)])-    smt2TV       = smt2 env . SVar-    ds           = smt2many (smt2ctor env as <$> cs)--smt2ctor :: SymEnv -> Int -> DataCtor -> Builder+    smt2TV = smt2 . SVar -smt2ctor env as (DCtor c fs)  = parenSeqs (smt2 env c : (smt2field env as <$> fs))+smt2ctor :: Int -> DataCtor -> SymM Builder+smt2ctor as (DCtor c fs) =+  do h <- smt2 c+     t <- traverse (smt2field as) fs+     pure $ parenSeqs (h : t) -smt2field :: SymEnv -> Int -> DataField -> Builder-smt2field env as d@(DField x t) = parenSeqs [smt2 env x, smt2SortPoly d env $ mkPoly as t]+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]  -- | 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.@@ -95,120 +114,153 @@     go is _        = is  instance SMTLIB2 Symbol where-  smt2 env s-    | Just t <- Thy.smt2Symbol env s = t-  smt2 _ s                           = symbolBuilder s-+  smt2 s = do env <- get+              case Thy.smt2Symbol env s of+                Just t  -> pure t+                Nothing -> pure $ symbolBuilder s instance SMTLIB2 Int where-  smt2 _ = Builder.fromString . show+  smt2 i = pure $ Builder.fromString $ show i  instance SMTLIB2 LocSymbol where-  smt2 env = smt2 env . val+  smt2 = smt2 . val  instance SMTLIB2 SymConst where-  smt2 env = smt2 env . symbol+  smt2 = smt2 . symbol  instance SMTLIB2 Constant where-  smt2 _ (I n)   = bShow n-  smt2 _ (R d)   = bFloat d-  smt2 _ (L t _) = fromText t+  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  instance SMTLIB2 Bop where-  smt2 _ Plus   = "+"-  smt2 _ Minus  = "-"-  smt2 _ Times  = symbolBuilder mulFuncName-  smt2 _ Div    = symbolBuilder divFuncName-  smt2 _ RTimes = "*"-  smt2 _ RDiv   = "/"-  smt2 _ Mod    = "mod"+  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"  instance SMTLIB2 Brel where-  smt2 _ Eq    = "="-  smt2 _ Ueq   = "="-  smt2 _ Gt    = ">"-  smt2 _ Ge    = ">="-  smt2 _ Lt    = "<"-  smt2 _ Le    = "<="-  smt2 _ _     = errorstar "SMTLIB2 Brel"+  smt2 Eq  = pure "="+  smt2 Ueq = pure "="+  smt2 Gt  = pure ">"+  smt2 Ge  = pure ">="+  smt2 Lt  = pure "<"+  smt2 Le  = pure "<="+  smt2 _   = errorstar "SMTLIB2 Brel"  -- NV TODO: change the way EApp is printed instance SMTLIB2 Expr where-  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 xs p)    = parenSeqs ["exists", parens (smt2s env xs), smt2 env p]-  smt2 env (PAll   [] p)    = smt2 env p-  smt2 env (PAll   xs p)    = parenSeqs ["forall", parens (smt2s env xs), 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)--+  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)  -- | smt2Cast uses the 'as x T' pattern needed for polymorphic ADT constructors --   like Nil, see `tests/pos/adt_list_1.fq` -smt2Cast :: SymEnv -> Expr -> Sort -> Builder-smt2Cast env (EVar x) t = smt2Var env x t-smt2Cast env e        _ = smt2    env e--smt2Var :: SymEnv -> Symbol -> Sort -> 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+smt2Cast :: Expr -> Sort -> SymM Builder+smt2Cast (EVar x) t = smt2Var x t+smt2Cast e        _ = smt2    e -smtLamArg :: SymEnv -> Symbol -> Sort -> Builder-smtLamArg env x t = Builder.fromText $ symbolAtName x env () (FFunc t FInt)+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 -smt2VarAs :: SymEnv -> Symbol -> Sort -> Builder-smt2VarAs env x t = parenSeqs ["as", smt2 env x, smt2SortMono x env t]+smt2VarAs :: Symbol -> Sort -> SymM Builder+smt2VarAs x t =+  do s <- smt2 x+     s1 <- smt2SortMono x t+     pure $ parenSeqs ["as", s, s1] -smt2Lam :: SymEnv -> (Symbol, Sort) -> Expr -> Builder-smt2Lam env (x, xT) full@(ECst _ eT) = parenSeqs [Builder.fromText lambda, x', smt2 env full]-  where-    x'     = smtLamArg env x xT-    lambda = symbolAtName lambdaName env () (FFunc xT eT)+-- 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 -smt2Lam _ _ e+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   = panic ("smtlib2: Cannot serialize unsorted lambda: " ++ showpp e) -smt2App :: SymEnv -> Expr -> Builder-smt2App env e@(EApp (EApp f e1) e2)+smt2App :: Expr -> SymM Builder+smt2App (EApp (EApp f e1) e2)   | Just t <- unApplyAt f-  = 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]+  = 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]   where-    (f, es)   = splitEApp' e+    (f, es) = splitEApp' e -smt2Coerc :: SymEnv -> Sort -> Sort -> Expr -> 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+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]  splitEApp' :: Expr -> (Expr, [Expr]) splitEApp'            = go []@@ -217,50 +269,76 @@   --   go acc (ECst e _) = go acc e     go acc e          = (e, acc) -mkRel :: SymEnv -> Brel -> Expr -> Expr -> 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 :: SymEnv -> Expr -> Expr -> Builder-mkNe env e1 e2      = key "not" (parenSeqs ["=",  smt2 env e1, smt2 env e2])+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] +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 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 paramxs rsort e) =-    let bParams = [ parenSeqs [smt2 env s, smt2 env t] | (s, t) <- paramxs]-     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)"+  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'] +  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 (Triggered Expr) where-  smt2 env (TR NoTrigger e)       = smt2 env e-  smt2 env (TR _ (PExist [] p))   = smt2 env p-  smt2 env t@(TR _ (PExist xs p)) = smtTr env "exists" xs p t-  smt2 env (TR _ (PAll   [] p))   = smt2 env p-  smt2 env t@(TR _ (PAll   xs p)) = smtTr env "forall" xs p t-  smt2 env (TR _ e)               = smt2 env e+  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  {-# INLINE smtTr #-}-smtTr :: SymEnv -> Builder -> [(Symbol, Sort)] -> Expr -> Triggered Expr -> Builder-smtTr env q xs p t = key q (parens (smt2s env xs) <+> key "!" (smt2 env p <+> ":pattern" <> parens (smt2s env (makeTriggers t))))+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))  {-# INLINE smt2s #-}-smt2s    :: SMTLIB2 a => SymEnv -> [a] -> Builder-smt2s env as = smt2many (smt2 env <$> as)+smt2s :: SMTLIB2 a => [a] -> SymM Builder+smt2s as = smt2many <$> traverse smt2 as  {-# INLINE smt2many #-} smt2many :: [Builder] -> Builder

@@ -3,7 +3,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE UndecidableInstances      #-}-{-# LANGUAGE PatternGuards             #-} {-# LANGUAGE ViewPatterns              #-}  {-# OPTIONS_GHC -Wno-orphans           #-}@@ -32,7 +31,7 @@      , dataDeclSymbols         -- * Theories-     , setEmpty, setEmp, setSng, setAdd, setMem+     , setEmpty, setEmp, setSng, setAdd, setMem, setCard      , setCom, setCap, setCup, setDif, setSub       , mapDef, mapSel, mapSto@@ -49,6 +48,9 @@      , arrConstB, arrStoreB, arrSelectB      , arrMapPlusB, arrMapLeB, arrMapGtB, arrMapIteB +     -- * CVC5 finite fields+     , ffVal, ffAdd, ffMul+       -- * Query Theories      , isSmt2App      , axiomLiterals@@ -56,6 +58,7 @@      ) where  import           Prelude hiding (map)+import           Control.Monad.State import           Data.ByteString.Builder (Builder) import           Language.Fixpoint.Types.Sorts import           Language.Fixpoint.Types.Config@@ -139,7 +142,8 @@ mapSel   = "Map_select" mapSto   = "Map_store" -setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: (IsString a) => a+setCard, setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: (IsString a) => a+setCard  = "Set_card" setEmpty = "Set_empty" setEmp   = "Set_emp" setCap   = "Set_cap"@@ -195,20 +199,34 @@ arrMapGtB   = "arr_map_gt" arrMapIteB   = "arr_map_ite" -strLen, strSubstr, strConcat :: (IsString a) => a -- Symbol+-- Finite field operations+ffVal, ffAdd, ffMul :: (IsString a) => a -- Symbol+ffVal = "FF_val"+ffAdd = "FF_add"+ffMul = "FF_mul"++strLen, strSubstr, strConcat, strConcat', strPrefixOf, strSuffixOf, strContains :: (IsString a) => a -- Symbol strLen    = "strLen" strSubstr = "subString" strConcat = "concatString"+strConcat' = "strConcat"+strPrefixOf  = "strPrefixOf"+strSuffixOf = "strSuffixOf"+strContains = "strContains" -smtlibStrLen, smtlibStrSubstr, smtlibStrConcat :: Raw+smtlibStrLen, smtlibStrSubstr, smtlibStrConcat, smtlibStrPrefixOf, smtlibStrSuffixOf, smtlibStrContains :: Raw smtlibStrLen    = "str.len" smtlibStrSubstr = "str.substr" smtlibStrConcat = "str.++"+smtlibStrPrefixOf = "str.prefixof"+smtlibStrSuffixOf = "str.suffixof"+smtlibStrContains = "str.contains" -strLenSort, substrSort, concatstrSort :: Sort+strLenSort, substrSort, concatstrSort, strCompareSort :: 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@@ -256,6 +274,7 @@      , (SOnly [Cvc5],       "(set-logic ALL)")      , (SOnly [Cvc4, Cvc5], "(set-option :incremental true)")      ]+  ++ setPreamble cfg   ++ boolPreamble cfg   ++ arithPreamble cfg   ++ stringPreamble cfg@@ -265,6 +284,10 @@ data PreambleCondition = SAll | SOnly [SMTSolver]   deriving (Eq, Show) +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") ]  boolPreamble :: Config -> [Preamble] boolPreamble _@@ -277,7 +300,7 @@  ]  stringPreamble :: Config -> [Preamble]-stringPreamble cfg | stringTheory cfg+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"))@@ -298,7 +321,7 @@ smt2Symbol env x = fromText . tsRaw <$> symEnvTheory x env  instance SMTLIB2 SmtSort where-  smt2 _ = smt2SmtSort+  smt2 s = pure $ smt2SmtSort s  smt2SmtSort :: SmtSort -> Builder smt2SmtSort SInt         = "Int"@@ -308,6 +331,7 @@ 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 (SBitVec n)  = key "_ BitVec" (bShow n) smt2SmtSort (SVar n)     = "T" <> bShow n smt2SmtSort (SData c []) = symbolBuilder c@@ -318,37 +342,44 @@ smt2SmtSorts :: [SmtSort] -> Builder smt2SmtSorts = seqs . fmap smt2SmtSort -type VarAs = SymEnv -> Symbol -> Sort -> Builder+type VarAs = Symbol -> Sort -> SymM Builder ---------------------------------------------------------------------------------smt2App :: VarAs -> SymEnv -> Expr -> [Builder] -> Maybe Builder+smt2App :: VarAs -> Expr -> [Builder] -> SymM (Maybe Builder) ---------------------------------------------------------------------------------smt2App _ env ex@(dropECst -> EVar f) [d]-  | f == arrConstS = Just (key (key "as const" (getTarget ex)) d)-  | f == arrConstB = Just (key (key "as const" (getTarget ex)) d)-  | f == arrConstM = Just (key (key "as const" (getTarget ex)) d)-  | f == setEmpty  = Just (key "as set.empty" (getTarget ex))-  | f == bagEmpty  = Just (key "as bag.empty" (getTarget ex))+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 :: Expr -> Builder+    getTarget :: SymEnv -> Expr -> Builder     -- const is a function, but SMT expects only the output sort-    getTarget (ECst _ t) = smt2SmtSort $ sortSmtSort True (seData env) (ffuncOut t)-    getTarget e = bShow e--smt2App k env ex (builder:builders)-  | Just fb <- smt2AppArg k env ex-  = Just $ key fb (builder <> mconcat [ " " <> d | d <- builders])--smt2App _ _ _ _    = Nothing+    getTarget env (ECst _ t) = smt2SmtSort $ sortSmtSort True (seData env) (ffuncOut t)+    getTarget _ e = bShow e -smt2AppArg :: VarAs -> SymEnv -> Expr -> Maybe Builder-smt2AppArg k env (ECst (dropECst -> EVar f) t)-  | Just fThy <- symEnvTheory f env-  = Just $ if isPolyCtor fThy t-            then k env f (ffuncOut t)-            else fromText (tsRaw fThy)+smt2App k ex (builder:builders) =+  do a <- smt2AppArg k ex+     pure $ (\fb -> key fb (builder <> mconcat [ " " <> d | d <- builders])) <$> a+smt2App _ _ [] = pure Nothing -smt2AppArg _ _ _-  = Nothing+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  isPolyCtor :: TheorySymbol -> Sort -> Bool isPolyCtor fThy t = isPolyInst (tsSort fThy) t && tsInterp fThy == Ctor@@ -388,9 +419,13 @@   theorySymbols :: [DataDecl] -> SEnv TheorySymbol   theorySymbols = fromListSEnv . concatMap dataDeclSymbols + 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@@ -414,6 +449,7 @@    -- 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))@@ -435,14 +471,15 @@   , interpSym bagMin   "bag.inter_min"      bagBopSort   , interpSym bagSub   "bag.subbag"         (FAbs 0 $ FFunc (bagSort $ FVar 0) $ FFunc (bagSort $ FVar 0) boolSort) -  -- , interpSym bvOrName  "bvor"  bvBopSort-  -- , interpSym bvAndName "bvand" bvBopSort-  -- , interpSym bvAddName "bvadd" bvBopSort-  -- , interpSym bvSubName "bvsub" bvBopSort+  -- 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 -  , interpSym strLen    strLen    strLenSort-  , interpSym strSubstr strSubstr substrSort-  , interpSym strConcat strConcat concatstrSort   , interpSym boolInt   boolInt   (FFunc boolSort intSort)    -- Function mappings for indexed identifier functions@@ -489,12 +526,18 @@   , 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 bv32intName   "(_ bv2int 32)" (FFunc bv32    intSort)-  -- , interpSym bv64intName   "(_ bv2int 64)" (FFunc bv64    intSort)+  , 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@@ -521,13 +564,22 @@   , 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-    -- (sizedBitVecSort "Size1")+    bv8        = sizedBitVecSort "Size8"+    bv16       = sizedBitVecSort "Size16"     bv32       = sizedBitVecSort "Size32"     bv64       = sizedBitVecSort "Size64"     boolInt    = boolToIntName@@ -630,17 +682,29 @@ interpSym :: Symbol -> Raw -> Sort -> (Symbol, TheorySymbol) interpSym x n t = (x, Thy x n t Theory) --- This variable is uded to generate the lambda names `lam_arg$n` in+-- 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 typees 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}` was not declared.+-- `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 :: [(Symbol, Sort)] -> [Expr]-axiomLiterals lts = catMaybes [ lenAxiom l <$> litLen l | (l, t) <- lts, isString t ]+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))++lenAxiomLiterals :: [(Symbol, Sort)] -> [Expr]+lenAxiomLiterals 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

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE TupleSections             #-} {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-}@@ -25,11 +26,18 @@     -- * SMTLIB2 Process Context     , Context (..) -    ) where+    -- * SMT monad+    , SmtM+    , liftSym+    , catchSMT+    , bracketSMT +    ) where+import           Control.Exception+import           Control.Monad.State import           Data.ByteString.Builder (Builder) import           Language.Fixpoint.Types-import           Language.Fixpoint.Types.Config (ElabFlags)+import           Language.Fixpoint.Types.Config (ElabFlags, Config) import qualified Data.Text                as T import           Text.PrettyPrint.HughesPJ import qualified SMTLIB.Backends@@ -59,6 +67,7 @@                   | Distinct [Expr] -- {v:[Expr] | 2 <= len v}                   | GetValue [Symbol]                   | CMany    [Command]+                  | Comment T.Text                   deriving (Eq, Show)  instance PPrint Command where@@ -81,6 +90,7 @@ ppCmd Distinct {} = text "Distinct ..." ppCmd GetValue {} = text "GetValue ..." ppCmd CMany {}    = text "CMany ..."+ppCmd (Comment t) = text ("; " ++ T.unpack t)  -- | Responses received from SMT engine data Response     = Ok@@ -102,15 +112,44 @@   , ctxLog     :: !(Maybe Handle)   , ctxVerbose :: !Bool   , ctxSymEnv  :: !SymEnv-  , ctxDefines :: ![Equation]+  -- | 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   } +-- | 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 :: SymEnv -> a -> Builder+  smt2 :: a -> SymM Builder -runSmt2 :: (SMTLIB2 a) => SymEnv -> a -> Builder+runSmt2 :: (SMTLIB2 a) => a -> SymM Builder runSmt2 = smt2

@@ -8,7 +8,7 @@  module Language.Fixpoint.Solver (     -- * Invoke Solver on an FInfo-    solve, Solver+    solve      -- * Invoke Solver on a .fq file   , solveFQ@@ -26,26 +26,28 @@  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.List as L import qualified Data.Text.Lazy.IO                as LT import qualified Data.Text.Lazy.Encoding          as LT import           System.Exit                        (ExitCode (..)) import           System.Console.CmdArgs.Verbosity   (whenNormal, whenLoud)-import           Text.PrettyPrint.HughesPJ          (render)-import           Control.Monad                      (mplus, when)-import           Control.Exception                  (catch)+import           Control.Monad                      (when)+import           Control.Exception                  (SomeException, catch)+import           Control.Exception.Compat+    (ExceptionWithContext(..), displayExceptionContext, wrapExceptionWithContext) 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)+import           Language.Fixpoint.SortCheck            (ElabParam (..), Elaborate (..), unElab, unElabFSetBagZ3) 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)@@ -56,10 +58,10 @@ import           Language.Fixpoint.Types hiding (GInfo(..), fi) import qualified Language.Fixpoint.Types as Types (GInfo(..)) import           Language.Fixpoint.Minimize (minQuery, minQuals, minKvars)-import           Language.Fixpoint.Solver.Instantiate (instantiate) import           Control.DeepSeq import qualified Data.ByteString as B-import Data.Maybe (catMaybes, mapMaybe)+import Data.Maybe (catMaybes)+import qualified Text.PrettyPrint.HughesPJ as PJ  --------------------------------------------------------------------------- -- | Solve an .fq file ----------------------------------------------------@@ -86,7 +88,7 @@     jStr    = LT.decodeUtf8 . encode $ r     stat    = resStatus $!! r     eCode   = resultExit . resStatus-    statStr = render . resultDoc+    statStr = PJ.render . resultDoc  ignoreQualifiers :: Config -> FInfo a -> FInfo a ignoreQualifiers cfg fi@@ -97,7 +99,9 @@ -------------------------------------------------------------------------------- -- | Solve FInfo system of horn-clause constraints ----------------------------- ---------------------------------------------------------------------------------solve :: (PPrint a, NFData a, Fixpoint a, Show a, Loc a) => Solver a+solve+  :: (PPrint a, NFData a, Fixpoint a, Show a, Loc a)+  => Config -> FInfo a -> IO (Result (Integer, a)) -------------------------------------------------------------------------------- solve cfg q   | parts cfg      = partition  cfg        $!! q@@ -107,15 +111,16 @@   | minimizeKs cfg = minKvars cfg solve'   $!! q   | otherwise      = solve'     cfg        $!! q -solve' :: (PPrint a, NFData a, Fixpoint a, Show a, Loc a) => Solver a++solve'+  :: (PPrint a, NFData a, Fixpoint a, Show a, Loc a)+  => Config -> FInfo a -> IO (Result (Integer, a)) solve' cfg q = do   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+  if multicore cfg then+    solvePar cfg q+  else+    solveNative cfg (slice cfg q)  -------------------------------------------------------------------------------- readFInfo :: FilePath -> IO (FInfo (), [String])@@ -140,17 +145,11 @@ -------------------------------------------------------------------------------- -- | Solve in parallel after partitioning an FInfo to indepdendant parts ---------------------------------------------------------------------------------solveSeqWith :: (Fixpoint a) => Solver a -> Solver a-solveSeqWith s c fi0 = {- withProgressFI fi $ -} s c fi-  where-    fi               = slice c fi0------------------------------------------------------------------------------------- | Solve in parallel after partitioning an FInfo to indepdendant parts----------------------------------------------------------------------------------solveParWith :: (Fixpoint a) => Solver a -> Solver a+solvePar+  :: (Loc a, NFData a, PPrint a, Show a, Fixpoint a)+  => Config -> FInfo a -> IO (Result (Integer, a)) ---------------------------------------------------------------------------------solveParWith s c fi0 = do+solvePar c fi0 = do   -- putStrLn "Using Parallel Solver \n"   let fi    = slice c fi0   mci      <- mcInfo c@@ -161,10 +160,10 @@   writeLoud $ "maximum part size    : " ++ show (maxPartSize c)   case fis of     []        -> errorstar "partiton' returned empty list!"-    [onePart] -> s c onePart-    _         -> inParallelUsing (f s c) $ zip [1..] fis+    [onePart] -> solveNative c onePart+    _         -> inParallelUsing (f c) $ zip [1..] fis     where-      f s' c' (j, fi) = s' (c {srcFile = queryFile (Part j) c'}) fi+      f c' (j, fi) = solveNative (c {srcFile = queryFile (Part j) c'}) fi  -------------------------------------------------------------------------------- -- | Solve a list of FInfos using the provided solver function in parallel@@ -180,26 +179,35 @@ -------------------------------------------------------------------------------- -- | Native Haskell Solver ----------------------------------------------------- ---------------------------------------------------------------------------------solveNative, solveNative' :: (NFData a, Fixpoint a, Show a, Loc a, PPrint a) => Solver a+solveNative, solveNative'+  :: (NFData a, Fixpoint a, Show a, Loc a, PPrint a)+  => Config -> FInfo a -> IO (Result (Integer, a)) -------------------------------------------------------------------------------- solveNative !cfg !fi0 = solveNative' cfg fi0                           `catch`-                             (return . crashResult (errorMap fi0))+                             (return . crashResult (errorMap fi0) . wrapExceptionWithContext)+                          `catch`+                             (return . crashResultOther . wrapExceptionWithContext) -crashResult :: (PPrint a) => ErrorMap a -> Error -> Result (Integer, a)-crashResult m err' = Result res mempty mempty mempty+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 err'-    msg | null ers = "Sorry, unexpected panic in liquid-fixpoint!"-        --  {-dbgFalse-} True  = "Sorry, unexpected panic in liquid-fixpoint!\n" ++ crashMessage es-        | otherwise = showpp err'+    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 -_crashMessage :: [((Integer, a), Maybe String) ] -> String-_crashMessage es = L.intercalate "\n" [ msg i s | ((i,_), Just s) <- es ]+crashResultOther+  :: ExceptionWithContext SomeException -> Result (Integer, a)+crashResultOther (ExceptionWithContext ectx ex) =+    Result res mempty mempty mempty   where-    msg i s = "Error in constraint " ++ show i ++ ":\n" ++ s+    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@@ -207,7 +215,7 @@ findError :: ErrorMap a -> Error1 -> Maybe ((Integer, a), Maybe String) findError m e = do   ann <- HashMap.lookup (errLoc e) m-  let str = render (errMsg e)+  let str = PJ.render (errMsg e)   return ((-1, ann), Just str)  -- The order is important here: we want the "binders" to get the "precedence"@@ -219,13 +227,13 @@             ++ [ a | (_, (_,_, a)) <- bindEnvToList (Types.bs fi) ]  loudDump :: (Fixpoint a) => Int -> Config -> SInfo a -> IO ()-loudDump i cfg si = when False (writeLoud $ msg ++ render (toFixpoint cfg si))+loudDump i cfg si = when False (writeLoud $ msg ++ PJ.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 (SInfo a)+               => Config -> FInfo a -> IO (ElabParam, SInfo a) simplifyFInfo !cfg !fi0 = do   -- writeLoud $ "fq file in: \n" ++ render (toFixpoint cfg fi)   -- rnf fi0 `seq` donePhase Loud "Read Constraints"@@ -250,13 +258,16 @@   -- writeLoud $ "fq file after defunc: \n" ++ render (toFixpoint cfg si4)   -- putStrLn $ "AXIOMS: " ++ showpp (asserts si4)   loudDump 2 cfg si4-  let si5  = {- SCC "elaborate" -} elaborate (ElabParam (solverFlags $ solver cfg) (atLoc dummySpan "solver") (symbolEnv cfg si4)) 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)   loudDump 3 cfg si5   let si6 = if extensionality cfg then {- SCC "expand" -} expand cfg si5 else si5-  if rewriteAxioms cfg && noLazyPLE cfg-    then instantiate cfg si6 $!! Nothing-    else return si6+  return (elabParam, si6){- SCC "elaborate" -}  reduceFInfo :: Fixpoint a => Config -> FInfo a -> IO (FInfo a) reduceFInfo cfg fi = do@@ -264,15 +275,15 @@       reducedFi = {- SCC "reduceEnvironments" -} reduceEnvironments simplifiedFi   when (save cfg) $     savePrettifiedQuery cfg reducedFi-  if noEnvironmentReduction cfg then+  if noEnvReduction cfg then     return fi   else     return reducedFi  solveNative' !cfg !fi0 = do-  si6 <- simplifyFInfo cfg fi0-  res0 <- {- SCC "Sol.solve" -} Sol.solve cfg $!! si6-  let res = simplifyResult res0+  (elabParam, si6) <- simplifyFInfo cfg fi0+  res0 <- {- SCC "Sol.solve" -} Sol.solve cfg elabParam $!! si6+  let res = simplifyResult cfg res0   -- rnf soln `seq` donePhase Loud "Solve2"   --let stat = resStatus res   -- saveSolution cfg res@@ -304,119 +315,27 @@   writeFile f $ unlines $     [ ""     , "Solution:"-    , showpp (resSolution  res)+    , scopedRender (resSolution  res)     ] ++-    ( if gradual cfg then-        ["", "", showpp $ gresSolution res]-      else-        []-    ) ++     [ ""     , ""     , "Non-cut kvars:"     , ""-    , showpp (HashMap.map unElab $ resNonCutsSolution res)+    , scopedRender (HashMap.map forceDelayed $ resNonCutsSolution res)     ]+    where+      scopedRender = PJ.render . PJ.vcat . map ncDoc . scoped+      scoped sol = [ (k, scope k, e) | (k, e) <- HashMap.toList sol]+      scope k = HashMap.lookupDefault [] k $ resSorts res+      ncDoc (k, xts, e) = PJ.hsep [ pprint k PJ.<> pprint xts, ":=", pprint e ] -simplifyResult :: Result a -> Result a-simplifyResult res =+simplifyResult :: Config -> Result a -> Result a+simplifyResult cfg res =     res-      { resSolution = HashMap.map simplifyKVar (resSolution res)-      , resNonCutsSolution = HashMap.map simplifyKVar (resNonCutsSolution res)+      { resSolution = HashMap.map simplifyKVar' (resSolution res)+      , resNonCutsSolution = HashMap.map (fmap simplifyKVar') (resNonCutsSolution res)       }---- | Simplifies existential expressions with unused or inconsequential bindings.------ 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"------ We require that relevant variables occur more than once, or that--- they occur in some other place than as an argument to @==@.----simplifyKVar :: Expr -> Expr-simplifyKVar (POr es) = POr $ map simplifyKVar es-simplifyKVar (PExist bs e@(PAnd es)) =-    let fvs = L.group $ L.sort $ collectFreeVarOccurrences e-        esv = map (isUniqueEq fvs) es-        removed = mapMaybe fst esv-        needed = map head fvs L.\\ removed-        bs' = filter ((`elem` needed) . fst) bs-     in-        PExist bs' $ PAnd $ [ei | (Nothing, ei) <- esv]   where-    -- | Determine if the expression is an equality that sets the value of-    -- a variable that doesn't occur elsewhere.-    ---    -- In @isUniqueEq fvs e@, @fvs@ contains the occurrences of the free-    -- variables, so we can infer if there is more than one occurrence-    -- of a given free variable, and @e@ is the equality to analyze.-    ---    -- Yields @(Just v, e)@ if @v@ doesn't occur elsewhere, and @e@ has-    -- the form @v == e'@.-    isUniqueEq :: [[Symbol]] -> Expr -> (Maybe Symbol, Expr)-    isUniqueEq fvs er = case unElab er of-      PAtom brel e0 e1-        | isEqRel brel ->-          let m = isVarToDrop fvs e0 `mplus` isVarToDrop fvs e1-           in (m, er)-      _ ->-        (Nothing, er)--    -- | Tells if the binary relation is an equality.-    isEqRel Eq = True-    isEqRel Ueq = True-    isEqRel _ = False--    -- | @isVarToDrop fvs s@ yields @Just s@ if the variable @s@ doesn't occur-    -- elsewhere according to @fvs@.-    ---    -- > isVarToDrop fvs (cast_as_int s) == isVarToDrop fvs s-    ---    isVarToDrop fvs (EApp (EVar "cast_as_int") ei) = isVarToDrop fvs ei-    isVarToDrop fvs (EVar s)-      | elem [s] fvs = Just s-    isVarToDrop _fvs _ = Nothing--simplifyKVar e = e---- | Produces the free variables of an expressions as many times as they occur.------ There are no guarantees on the order in which the variables are produced. For--- instance,------ > collectFreeVarOccurrences "z (y x) (y x)" == ["z", "y", "x", "y", "x"]----collectFreeVarOccurrences :: Expr -> [Symbol]-collectFreeVarOccurrences = go []-  where-    go acc e0 = case e0 of-      ESym _ -> acc-      ECon _ -> acc-      EVar v -> v : acc-      PKVar _ (Su m) -> foldr (flip go) acc $ HashMap.elems m-      PGrad _ (Su m) _ e -> foldr (flip go) acc $ e : HashMap.elems m-      ENeg e -> go acc e-      PNot p -> go acc p-      ECst e _t -> go acc e-      PAll _xts p -> go acc p-      ELam (b, _) e -> go acc e L.\\ [b]-      ECoerc _a _t e -> go acc e-      PExist _xts p -> go acc p-      ETApp e _s -> go acc e-      ETAbs e _s -> go acc e-      EApp g e -> go (go acc e) g-      EBin _o e1 e2 -> go (go acc e2) e1-      PImp p1 p2 -> go (go acc p2) p1-      PIff p1 p2 -> go (go acc p2) p1-      PAtom _r e1 e2 -> go (go acc e2) e1-      EIte p e1 e2 -> go (go (go acc e2) e1) p-      PAnd ps -> foldr (flip go) acc ps-      POr ps -> foldr (flip go) acc ps+    simplifyKVar' = unElabSets . unElab . Sol.simplifyKVar HashSet.empty+    sets          = elabSetBag . solverFlags $ cfg+    unElabSets    = if sets then unElabFSetBagZ3 else id

@@ -2,30 +2,39 @@  module Language.Fixpoint.Solver.Common (askSMT, toSMT) where -import Language.Fixpoint.Types.Config (Config, solver, solverFlags)+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 :: Config -> Context -> [(Symbol, Sort)] -> Expr -> IO Bool-askSMT cfg ctx xs e---   | isContraPred e  = return False+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) = checkValidWithContext ctx xs PTrue e'+  | null (kvarsExpr e) =+      do ctx <- get+         let e' = toSMT "askSMT" cfg ctx (xs ++ bsInSMT) e+         checkValidWithContext xs PTrue e'   | otherwise          = return False-  where-    e' = toSMT "askSMT" cfg ctx xs e -toSMT :: String -> Config -> Context -> [(Symbol, Sort)] -> Expr -> Pred+toSMT :: HasCallStack => String -> Config -> Context -> [(Symbol, Sort)] -> Expr -> Pred toSMT msg cfg ctx xs e =     defuncAny cfg symenv .-        elaborate (ElabParam (solverFlags $ solver cfg) (dummyLoc msg) (elabEnv xs)) .-            mytracepp ("toSMT from " ++ msg ++ showpp e) $+        elaborate (ElabParam (solverFlags cfg) (dummyLoc msg) (elabEnv xs)) .+            mytracepp ("toSMT from " ++ msg ++ " > " ++ showpp e) $                 e   where     elabEnv = insertsSymEnv symenv

@@ -16,39 +16,61 @@ 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 b+solverInfo :: Config -> SInfo a -> SolverInfo a -------------------------------------------------------------------------------- solverInfo cfg sI = SI sHyp sI' cD cKs   where-    cD             = elimDeps     sI es nKs ebs+    cD             = elimDeps     sI es nKs     sI'            = cutSInfo     sI kI cKs-    sHyp           = Sol.fromList sE mempty mempty kHyps kS [] sEnv-    sEnv           = fromListSEnv [ (x, (i, sr_sort sr)) | (i, (x,sr, _)) <- bindEnvToList (bs sI)]+    sHyp = Sol.Sol+      { Sol.sMap = mempty+      , Sol.sHyp = M.fromList kHyps+      , Sol.sScp = kS+      }     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 [x | i <- ebinds sI, let (x, _, _) = lookupBindEnv i (bs 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 = is2env <$> kiM+kvScopes sI es = commonBindingsOfConstraints <$> kvarUses   where-    is2env = foldr1 intersectionIBindEnv . fmap (senv . getSubC sI)-    kiM    = group $ [(k, i) | (Cstr i, KVar k) <- es ] ++-                     [(k, i) | (KVar k, Cstr i) <- es ]+    -- | 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 ] +--------------------------------------------------------------------------------+-- | @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@@ -57,13 +79,17 @@     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] 

@@ -33,9 +33,9 @@ import           Data.HashSet (HashSet) import qualified Data.HashSet as HashSet #if MIN_VERSION_base(4,20,0)-import           Data.List (nub, partition)+import           Data.List (partition) #else-import           Data.List (foldl', nub, partition)+import           Data.List (foldl', partition) #endif import           Data.Maybe (fromMaybe) import           Data.ShareMap (ShareMap)@@ -153,7 +153,6 @@      { bs = bs'      , cm = HashMap.fromList cm'      , ws = ws'-     , ebinds = updateEbinds bs' (ebinds finfo)      , bindInfo = updateBindInfoKeys bs' $ bindInfo finfo      } @@ -170,9 +169,6 @@        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)@@ -310,10 +306,17 @@   filter relevantBind env   where     allSymbols =-      reachableSymbols (HashSet.union extraSymbols envSymbols) aenvMap+      reachableSymbols (HashSet.unions [extraSymbols, envSymbols, withKVars]) 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+     relevantBind (s, _, sr, _)       | HashSet.member s allSymbols = True       | otherwise = case reftPred (sr_reft sr) of@@ -470,15 +473,9 @@    in finfo         { bs = bs'         , cm = cm'-        , ebinds = updateEbinds oldToNew (ebinds finfo)         , bindInfo = updateBindInfoKeys oldToNew $ bindInfo finfo         }   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 =@@ -516,7 +513,7 @@            mergedEnv = mergeDuplicatedBindings env           undoANFEnv =-            if inlineANFBindings cfg then undoANFOnlyModified mergedEnv else HashMap.empty+            if inlineANFBinds cfg then undoANFOnlyModified mergedEnv else HashMap.empty           boolSimplEnv =             simplifyBooleanRefts $ HashMap.union undoANFEnv mergedEnv @@ -749,7 +746,13 @@ dropLikelyIrrelevantBindings ss env = HashMap.filterWithKey relevant env   where     directlyUses = HashMap.map (exprSymbolsSet . reftPred . sr_reft) env-    relatedSyms = relatedSymbols ss directlyUses+    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     relevant s _sr =       (not (capitalizedSym s) || prefixOfSym s /= s) && s `HashSet.member` relatedSyms     capitalizedSym = Text.all isUpper . Text.take 1 . symbolText

@@ -24,7 +24,7 @@ mytracepp = notracepp  expand :: Config -> SInfo a -> SInfo a-expand cfg si = evalState (ext si) $ initST (symbolEnv cfg si) (ddecls si) (solverFlags $ solver cfg)+expand cfg si = evalState (ext si) $ initST (symbolEnv cfg si) (ddecls si) (solverFlags cfg)   where     ext :: SInfo a -> Ex a (SInfo a)     ext = extend@@ -148,6 +148,8 @@     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+     -- The below cannot appear due to normalization     go p (PNot e)        = f p . PNot =<< go p e     go p (PIff p1 p2)    = f p =<< (PIff        <$>  go p p1 <*> go p p2            )@@ -160,7 +162,6 @@     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'@@ -181,12 +182,12 @@     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 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)

@@ -1,135 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE FlexibleInstances  #-}--module Language.Fixpoint.Solver.GradualSolution-  ( -- * Create Initial Solution-    init-  ) where--import           Control.Parallel.Strategies-import           Control.Monad.Reader-import qualified Data.HashMap.Strict            as M-import qualified Data.List                      as L-import           Data.Maybe                     (maybeToList, isNothing)-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 qualified Language.Fixpoint.Types.Constraints  as Cons-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 (runReader (traverse (refineG si qs genv) gs) ef) `using` parList rdeepseq-  where-    qs         = F.quals si-    gs         = snd <$> gs0-    genv       = instConstants si--    gs0        = L.filter (Cons.isGWfc . snd) $ M.toList (F.ws si)--    elab (k, (x,es)) = (k, (x, elaborate (ElabParam ef (F.atLoc F.dummySpan "init") (sEnv (Cons.gsym x) (Cons.gsort x))) <$> es))--    sEnv x s    = isEnv {F.seSort = F.insertSEnv x s (F.seSort isEnv)}-    isEnv       = symbolEnv cfg si-    ef          = solverFlags $ solver cfg------------------------------------------------------------------------------------refineG :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> ElabM (F.KVar, (F.GWInfo, [F.Expr]))-refineG fi qs genv w =-  do (k, qb) <- refine fi qs genv w-     pure (k, (F.gwInfo w, Sol.qbExprs qb))--refine :: F.SInfo a -> [F.Qualifier] -> F.SEnv F.Sort -> F.WfC a -> ElabM (F.KVar, Sol.QBind)-refine fi qs genv w = refineK (Cons.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) -> ElabM (F.KVar, Sol.QBind)-refineK ho env qs (v, t, k) =-  do eqs' <- Sol.qbFilterM (okInst env v t) eqs-     pure (k, eqs')-   where-    eqs                     = instK ho env v t qs------------------------------------------------------------------------------------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 =-  case Cons.qpSort <$> F.qParams q of-    (qt:qts) -> do-        (su0, v0) <- candidates senv [(t, [v])] qt-        xs        <- match senv tyss [v0] (So.apply su0 <$> qts)-        return     $ Sol.eQual q (reverse xs)-      where-        tyss       = instCands ho env-        senv       = (`F.lookupSEnvWithDistance` env)-    [] -> error "Empty qpSort of qParams q"--instCands :: Bool -> F.SEnv F.Sort -> [(F.Sort, [F.Symbol])]-instCands ho env = filter isOk tyss-  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 -> ElabM Bool----------------------------------------------------------------------------------okInst env v t eq =-  do tc <- So.checkSorted F.dummySpan env sr-     pure $ isNothing tc-  where-    sr            = F.RR t (F.Reft (v, p))-    p             = Sol.eqPred eq---

@@ -1,328 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}------------------------------------------------------------------------------------- | 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----}

@@ -1,816 +0,0 @@------------------------------------------------------------------------------------ | This module implements "Proof by Logical Evaluation" where we---   unfold function definitions if they *must* be unfolded, to strengthen---   the environments with function-definition-equalities.---   The algorithm is discussed at length in:------     1. "Refinement Reflection", POPL 2018, https://arxiv.org/pdf/1711.03842---     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf-----------------------------------------------------------------------------------{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE PartialTypeSignatures     #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE 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 qualified Language.Fixpoint.Solver.Common as Common (toSMT)-import           Language.Fixpoint.Solver.Common          (askSMT)-import           Control.Monad ((>=>), foldM, forM, forM_, join)-import           Control.Monad.State-import           Data.Bifunctor (first, 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            (isDigit, 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 info subcIds-  | not (oldPLE cfg)-  = PLE.instantiate cfg info subcIds--  | noIncrPle cfg-  = instantiate' cfg info subcIds--  | otherwise-  = incrInstantiate' cfg info 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 info subcIds = do-    let cs = [ (i, c) | (i, c) <- M.toList (cm info), 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 (defns info) (pleTrie t . instEnv cfg info cs)  -- 2. TRAVERSE Trie to compute InstRes-    return $ resSInfo cfg sEnv info res                                 -- 3. STRENGTHEN SInfo using InstRes-  where-    file   = srcFile cfg ++ ".evals"-    sEnv   = symbolEnv cfg info-    aEnv   = ae info-------------------------------------------------------------------------------------- | Step 1a: @instEnv@ sets up the incremental-PLE environment-instEnv :: (Loc a) => Config -> SInfo a -> [(SubcId, SimpC a)] -> SMT.Context -> InstEnv a-instEnv cfg info cs ctx = InstEnv cfg ctx bEnv aEnv (M.fromList cs) γ s0-  where-    bEnv              = bs info-    aEnv              = ae info-    γ                 = 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 = go []-  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 info res = strengthenBinds info res'-  where-    res'     = M.fromList $ mytracepp  "ELAB-INST:  " $ zip is ps''-    ps''     = zipWith (\i -> elaborate (ElabParam (solverFlags $ solver 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-  , ieSMT   :: !SMT.Context-  , ieBEnv  :: !(BindEnv a)-  , ieAenv  :: !AxiomEnv-  , ieCstrs :: !(M.HashMap SubcId (SimpC a))-  , ieKnowl :: !Knowledge-  , ieEvEnv :: !EvalEnv-  }---- | @ICtx@ is the local information -- at each trie node -- obtained by incremental PLE-data ICtx    = ICtx-  { icAssms  :: ![Pred]          -- ^ Hypotheses, already converted to SMT format-  , 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 subId = msg-  where-    msg                          = "INCR-INSTANTIATE i = " ++ show subId ++ ": " ++ showpp cidEqs-    cidEqs                       = pAnd [ e | i <- cBinds, e <- Mb.maybeToList $ M.lookup i res ]-    cBinds                       = L.sort . elemsIBindEnv . senv . getCstr ieCstrs $ subId---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 [] <$>-                  (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     = [ (x, y)  | i <- delta, let (x, y, _) = lookupBindEnv i ieBEnv ]-    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 info subcIds = sInfo cfg env info <$> withCtx cfg file env (defns info) act-  where-    act ctx         = forM cstrs $ \(i, c) ->-                        ((i,srcSpan c),) . mytracepp  ("INSTANTIATE i = " ++ show i) <$> instSimpC cfg ctx (bs info) aenv i c-    cstrs           = [ (i, c) | (i, c) <- M.toList (cm info) , isPleCstr aenv i c-                               ,  maybe True (i `L.elem`) subcIds ]-    file            = srcFile cfg ++ ".evals"-    env             = symbolEnv cfg info-    aenv            = {- mytracepp  "AXIOM-ENV" -} ae info--sInfo :: Config -> SymEnv -> SInfo a -> [((SubcId, SrcSpan), Expr)] -> SInfo a-sInfo cfg env info ips = strengthenHyp info (mytracepp  "ELAB-INST:  " $ zip (fst <$> is) ps'')-  where-    (is, ps)         = unzip ips-    ps'              = defuncAny cfg env ps-    ps''             = zipWith (\(i, sp) -> elaborate (ElabParam (solverFlags $ solver cfg) (atLoc sp ("PLE1 " ++ show i)) env)) is ps'--instSimpC :: Config -> SMT.Context -> BindEnv a -> AxiomEnv -> SubcId -> SimpC a -> IO Expr-instSimpC cfg ctx bds aenv subId sub-  | isPleCstr aenv subId 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 subId-    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 subId c = isTarget c && M.lookupDefault False subId (aenvExpand aenv)--cstrExprs :: BindEnv a -> 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 subId = do-  let eqs      = initEqualities ctx aenv facts-  let γ        = knowledge cfg ctx aenv-  let cands    = mytracepp  ("evaluate-cands " ++ showpp subId) $ Misc.setNub (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 = loop 0 []-  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 :: Integer) 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  = f `notElem` 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 `traverse` es)-    go (POr es)         = POr          <$> (go `traverse` es)-    go e                = return e---- | `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 = go []-  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   <- gets (seSort . 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      <- gets (seSort . evEnv)-       mytracepp ("EVAL-REC-APP" ++ showpp (stk, _e))-         <$> evalRecApplication γ (pushCS stk f) (eApps (EVar f) es) (substEq env Normal eq es bd)--evalAppAc _ _ _ (f, es)-  = 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 symToSearch ts)-    symToSearch = 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 sort1 sort2 = mytracepp  ("matchSorts :" ++ showpp (sort1, sort2)) $ go sort1 sort2-  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 expr' = L.foldl' go expr' 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.setNub (Mb.catMaybes [getDCEquality symEnv' e1 e2 | EEq e1 e2 <- atoms])-    atoms                  = splitPAnd . expr =<< filter isProof es-    symEnv'                = SMT.ctxSymEnv ctx---- AT: Non-obvious needed invariant: askSMT True is always the--- totality-effecting one.--- RJ: What does "totality effecting" mean?--toSMT :: Config -> SMT.Context -> [(Symbol, Sort)] -> Expr -> Pred-toSMT = Common.toSMT "Instantiate.toSMT"--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) = first (getDC sEnv) (splitEApp e1)-    (f2, es2) = first (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)-      | isTupleSymbol s' = s'-      | otherwise        = f $ T.splitOn d $ stripParens s-    stripParens t = Mb.fromMaybe t ((T.stripPrefix "(" >=> T.stripSuffix ")") t)--    -- TODO: Remove this code which is LH specific-    isTupleSymbol :: Symbol -> Bool-    isTupleSymbol s =-      let t = symbolText s-       in T.isPrefixOf "Tuple" t &&-          T.all isDigit (T.drop 5 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 γ expr' = do-    sims <- gets (aenvSimpl . _evAEnv)-    -- cfg  <- gets evCfg-    -- _    <- foldlM (\_ s -> Vis.mapMExpr (go s) e) (mytracepp  "assertSelector" e) sims-    forM_ sims $ \s -> Vis.mapMExpr (go s) expr'-  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 -> [Equation] -> (SMT.Context -> IO a) -> IO a-withCtx cfg file env defns k = do-  ctx <- SMT.makeContextWithSEnv cfg file env defns-  _   <- SMT.smtPush ctx-  res <- k ctx-  SMT.cleanupContext ctx-  return res--infixl 9 ~>-(~>) :: (Expr, String) -> Expr -> EvalST Expr-(e, _str) ~> e' = do-  let msg = "PLE: " ++ _str ++ showpp (e, e')-  modify (\st -> st {evId = mytracepp msg (evId st) + 1})-  return e'

@@ -57,7 +57,7 @@ -------------------------------------------------------------------------------- -- | Strengthen Constraint Environments via PLE ---------------------------------------------------------------------------------instInterpreter :: (Loc a) => Config -> SInfo a -> Maybe [SubcId] -> IO (SInfo a)+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)@@ -178,11 +178,11 @@ -- | Step 3: @resSInfo@ uses incremental PLE result @InstRes@ to produce the strengthened SInfo ---------------------------------------------------------------------------------------------- -resSInfo :: Config -> SymEnv -> SInfo a -> InstRes -> SInfo a+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 $ solver cfg) (atLoc dummySpan ("PLE1 " ++ show i)) env)) 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) @@ -358,6 +358,7 @@       EIte b _ _ -> go b $ e0 : acc       ECoerc _ _ e -> go e acc       ECst e _ -> go e acc+      ELet{} -> acc       ESym _ -> acc       ECon _ -> acc       EVar _ -> acc@@ -367,7 +368,6 @@       PKVar _ _ -> acc       PAll _ _ -> acc       PExist _ _ -> acc-      PGrad{} -> acc  largestApps :: Expr -> [Expr] largestApps = flip go []@@ -388,13 +388,13 @@       ESym _ -> acc       ECon _ -> acc       EVar _ -> e0 : acc+      ELet{} -> acc       ELam _ _ -> acc       ETApp _ _ -> acc       ETAbs _ _ -> acc       PKVar _ _ -> acc       PAll _ _ -> acc       PExist _ _ -> acc-      PGrad{} -> acc  fastEval :: ConstMap -> Knowledge -> ICtx -> Expr -> EvalST Expr fastEval ienv γ ctx e@@ -554,9 +554,11 @@ interpret ie γ ctx env e@(PExist xss e1) = case xss of   [] -> interpret' ie γ ctx env e1   _  -> e-interpret _  _ _   _   e@PGrad{}         = e interpret ie γ ctx env (ECoerc s t e)    = let e' = interpret' ie γ ctx env e in                                              if s == t then e' else ECoerc s t e'+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'   --------------------------------------------------------------------------------

@@ -5,19 +5,16 @@ module Language.Fixpoint.Solver.Monad        ( -- * Type          SolveM+       , liftSMT           -- * Execution        , runSolverM -         -- * Get Binds-       , getBinds        , getContext           -- * SMT Query        , filterRequired        , filterValid-       , filterValidGradual-       , checkSat        , smtEnablembqi        , sendConcreteBindingsToSMT @@ -27,10 +24,12 @@        , stats        , numIter        , SolverState(..)++       , modifyContext        )        where -import           Control.Monad (foldM, forM, forM_, when)+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)@@ -43,18 +42,20 @@ 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 --------------------------------------------------------@@ -64,8 +65,8 @@  data SolverState ann = SS   { ssCtx     :: !Context         -- ^ SMT Solver Context-  , ssBinds   :: !(F.BindEnv ann) -- ^ All variables and types   , ssStats   :: !Stats           -- ^ Solver Statistics+  , ssElabParam :: !ElabParam      -- ^ Elaboration Parameters   }  stats0    :: F.GInfo c b -> Stats@@ -74,31 +75,24 @@     nCs   = M.size $ F.cm fi  ---------------------------------------------------------------------------------runSolverM :: Config -> SolverInfo ann c -> SolveM ann a -> IO a+runSolverM :: Config -> SolverInfo ann -> ElabParam -> SolveM ann a -> IO a ---------------------------------------------------------------------------------runSolverM cfg sI act =+runSolverM cfg sI elabParam act =   bracket acquire release $ \ctx -> do     res <- runStateT act' (s0 ctx)     return (fst res)   where-    s0 ctx   = SS ctx be (stats0 fi)+    s0 ctx   = SS ctx (stats0 fi) elabParam     act'     = assumesAxioms (F.asserts fi) >> act     release  = cleanupContext     acquire  = makeContextWithSEnv cfg file initEnv (F.defns fi)     initEnv  = symbolEnv cfg fi-    be       = F.bs fi     file     = C.srcFile cfg     -- only linear arithmetic when: linear flag is on or solver /= Z3     -- lar     = linear cfg || Z3 /= solver cfg     fi       = (siQuery sI) {F.hoInfo = F.cfgHoInfo cfg } - ---------------------------------------------------------------------------------getBinds :: SolveM ann (F.BindEnv ann)----------------------------------------------------------------------------------getBinds = ssBinds <$> get---------------------------------------------------------------------------------- getIter :: SolveM ann Int -------------------------------------------------------------------------------- getIter = numIter . ssStats <$> get@@ -115,8 +109,13 @@ incChck n = modifyStats $ \s -> s {numChck = n + numChck s} incVald n = modifyStats $ \s -> s {numVald = n + numVald s} -withContext :: (Context -> IO a) -> SolveM ann a-withContext k = (lift . k) =<< getContext+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  getContext :: SolveM ann Context getContext = ssCtx <$> get@@ -124,6 +123,9 @@ modifyStats :: (Stats -> Stats) -> SolveM ann () 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 ------------------------------------------------------------- --------------------------------------------------------------------------------@@ -133,9 +135,8 @@ -- -- Yields the ids of bindings known to the SMT sendConcreteBindingsToSMT-  :: F.IBindEnv -> (F.IBindEnv -> SolveM ann a) -> SolveM ann a-sendConcreteBindingsToSMT known act = do-  be <- getBinds+  :: F.IBindEnv -> F.BindEnv ann -> (F.IBindEnv -> SolveM ann a) -> SolveM ann a+sendConcreteBindingsToSMT known be act = do   let concretePreds =         [ (i, F.subst1 p (v, F.EVar s))         | (i, (s, F.RR _ (F.Reft (v, p)),_)) <- F.bindEnvToList be@@ -144,12 +145,16 @@         , not (F.memberIBindEnv i known)         ]   st <- get-  (a, st') <- withContext $ \me -> do-    smtBracket me "" $ do+  (a, st'') <- liftSMT $+    smtBracket "sendConcreteBindingsToSMT" $ do       forM_ concretePreds $ \(i, e) ->-        smtDefineFunc me (F.bindSymbol (fromIntegral i)) [] F.boolSort e-      flip runStateT st $ act $ F.unionIBindEnv known $ F.fromListIBindEnv $ map fst concretePreds-  put st'+        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''' }   return a   where     isShortExpr F.PTrue = True@@ -170,9 +175,9 @@ filterValid :: F.SrcSpan -> F.Expr -> F.Cand a -> SolveM ann [a] -------------------------------------------------------------------------------- filterValid sp p qs = do-  qs' <- withContext $ \me ->-           smtBracket me "filterValidLHS" $-             filterValid_ sp p qs me+  qs' <- liftSMT $+           smtBracket "filterValidLHS" $+             filterValid_ sp p qs   -- stats   incBrkt   incChck (length qs)@@ -180,66 +185,23 @@   return qs'  {-# SCC filterValid_ #-}-filterValid_ :: F.SrcSpan -> F.Expr -> F.Cand a -> Context -> IO [a]-filterValid_ sp p qs me = catMaybes <$> do-  smtAssert me p+filterValid_ :: F.SrcSpan -> F.Expr -> F.Cand a -> SmtM [a]+filterValid_ sp p qs = catMaybes <$> do+  smtAssertDecl p   forM qs $ \(q, x) ->-    smtBracketAt sp me "filterValidRHS" $ do-      smtAssert me (F.PNot q)-      valid <- smtCheckUnsat me+    smtBracketAt sp "filterValidRHS" $ do+      smtAssertDecl (F.PNot q)+      valid <- smtCheckUnsat       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 ann [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) ->-    smtBracket me "filterValidRHS" $ do-      smtAssert me (F.PNot q)-      valid <- smtCheckUnsat me-      return ((q, x), valid)- smtEnablembqi :: SolveM ann () smtEnablembqi-  = withContext smtSetMbqi-----------------------------------------------------------------------------------checkSat :: F.Expr -> SolveM ann Bool----------------------------------------------------------------------------------checkSat p-  = withContext $ \me ->-      smtBracket me "checkSat" $-        smtCheckSat me p+  = liftSMT smtSetMbqi  -------------------------------------------------------------------------------- assumesAxioms :: [F.Triggered F.Expr] -> SolveM ann () ---------------------------------------------------------------------------------assumesAxioms es = withContext $ \me -> forM_  es $ smtAssertAxiom me+assumesAxioms es = liftSMT $ forM_ es smtAssertAxiom   ---------------------------------------------------------------------------

@@ -8,6 +8,7 @@ --     2. "Reasoning about Functions", VMCAI 2018, https://ranjitjhala.github.io/static/reasoning-about-functions.pdf -------------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE PartialTypeSignatures     #-} {-# LANGUAGE TupleSections             #-}@@ -30,10 +31,11 @@  import           Language.Fixpoint.Types hiding (simplify) import           Language.Fixpoint.Types.Config  as FC-import           Language.Fixpoint.Types.Solutions (CMap)+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@@ -44,6 +46,7 @@ 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@@ -51,7 +54,7 @@ import Language.REST.RuntimeTerm as RT import Language.REST.SMT (withZ3, SolverHandle) -import           Control.Monad (filterM, foldM, forM_, when, replicateM)+import           Control.Monad (filterM, foldM, forM_, when, replicateM, zipWithM) import           Control.Monad.State import           Control.Monad.Trans.Maybe import           Data.Bifunctor (second)@@ -71,26 +74,31 @@  -------------------------------------------------------------------------------- -- | 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 [SubcId] -> IO (SInfo a)-instantiate cfg fi' subcIds = do+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 -> withProgress (1 + M.size cs) $-               withCtx cfg file sEnv (defns fi') $ \ctx -> do-                  env <- instEnv cfg info cs solver ctx-                  pleTrie t env                                             -- 2. TRAVERSE Trie to compute InstRes-    savePLEEqualities cfg info sEnv res+    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 -> IO a) -> IO a+    withRESTSolver :: (Maybe SolverHandle -> SmtM a) -> SmtM a     withRESTSolver f | all null (M.elems $ aenvAutoRW aEnv) = f Nothing     withRESTSolver f = withZ3 (f . Just) -    file = srcFile cfg ++ ".evals"     sEnv = symbolEnv cfg info     aEnv = ae info     info = normalize fi'@@ -107,7 +115,7 @@   where     equalitiesPerConstraint (cid, c) =       (cid, L.sort [ e | i <- elemsIBindEnv (senv c), Just e <- [M.lookup i res] ])-    elabParam = ElabParam (solverFlags $ solver cfg) "savePLEEqualities" sEnv+    elabParam = ElabParam (solverFlags cfg) "savePLEEqualities" sEnv     renderConstraintRewrite (cid, eqs) =       "constraint id" <+> text (show cid ++ ":")       $+$ nest 2@@ -122,10 +130,18 @@  ------------------------------------------------------------------------------- -- | Step 1a: @instEnv@ sets up the incremental-PLE environment-instEnv :: (Loc a) => Config -> SInfo a -> CMap (SimpC a) -> Maybe SolverHandle -> SMT.Context -> IO (InstEnv a)-instEnv cfg info cs restSolver ctx = do-    refRESTCache <- newIORef mempty-    refRESTSatCache <- newIORef mempty+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@@ -145,6 +161,8 @@         s0 = EvalEnv               { evEnv = SMT.ctxSymEnv ctx               , evElabF = ef+              , evKCtx = ctx+              , evExScope = []               , evPendingUnfoldings = mempty               , evNewEqualities = mempty               , evSMTCache = mempty@@ -157,16 +175,16 @@               }     return $ InstEnv        { ieCfg = cfg-       , ieSMT = ctx-       , ieBEnv = coerceBindEnv ef (bs info)+       , ieBEnv = bs info        , ieAenv = ae info        , ieCstrs = cs-       , ieKnowl = knowledge cfg ctx info+       , ieKnowl = knowledge cfg info        , ieEvEnv = s0        , ieLRWs  = lrws info+       , ieSol  = s        }   where-    ef = solverFlags $ solver cfg+    ef = solverFlags cfg      cachedNotStrongerThan refRESTCache oc a b = do       m <- readIORef refRESTCache@@ -212,7 +230,7 @@  ---------------------------------------------------------------------------------------------- -- | Step 2: @pleTrie@ walks over the @CTrie@ to actually do the incremental-PLE-pleTrie :: CTrie -> InstEnv a -> IO InstRes+pleTrie :: Loc a => CTrie -> InstEnv a -> SmtM InstRes pleTrie t env = loopT env ctx0 diff0 Nothing res0 t   where     diff0        = []@@ -225,42 +243,54 @@       , icSubcId             = Nothing       , icANFs               = []       , icLRWs               = mempty+      , icBindIds            = mempty       , icEtaBetaFlag        = etabeta        $ ieCfg env       , icExtensionalityFlag = extensionality $ ieCfg env       , icLocalRewritesFlag  = localRewrites  $ ieCfg env+      , icFreshExistentialCounter = 0+      , icInitialLHSs  = mempty       }  loopT-  :: InstEnv a+  :: 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-  -> IO InstRes-loopT env ctx delta i res t = case t of+  -> SmtM InstRes+loopT env ictx 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'', env'', res') <- ple1 env ctx' i res-                  foldM (loopB env'' ctx'' [] i) res' bs+  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-  :: InstEnv a+  :: 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-  -> 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-                  (\(_, _, r) -> r) <$> ple1 env ctx' iMb res+  -> 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@. --@@ -271,35 +301,59 @@ -- 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'+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 ieSMT "PLE.evaluate" $ do-    forM_ assms (SMT.smtAssert ieSMT)-    act ctx' { icAssms = mempty }+  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 -> IO (ICtx, InstEnv a, InstRes)-ple1 ie@InstEnv{..} ctx i res = do-  (ctx', env) <- runStateT (evalCandsLoop ieCfg ctx ieSMT ieKnowl) ieEvEnv-  let pendings = collectPendingUnfoldings env (icSubcId ctx)-      newEqs = pendings ++ S.toList (S.difference (icEquals ctx') (icEquals ctx))-  return (ctx', ie { ieEvEnv = env }, updCtxRes res i newEqs)+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 _) | pleWithUndecidedGuards ieCfg =-      M.toList (evPendingUnfoldings env)-    collectPendingUnfoldings _ _ = []+    collectPendingUnfoldings env (Just _) | pleUndecGuards ieCfg =+      M.map (S.fromList . M.toList) (evPendingUnfoldings env)+    collectPendingUnfoldings _ _ = mempty -evalToSMT :: String -> Config -> SMT.Context -> (Expr, Expr) -> Pred-evalToSMT msg cfg ctx (e1,e2) = toSMT ("evalToSMT:" ++ msg) cfg ctx [] (EEq e1 e2)+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@@ -316,44 +370,72 @@ -- > until no new equalities are discovered -- >       or the environment becomes inconsistent ---evalCandsLoop :: Config -> ICtx -> SMT.Context -> Knowledge -> EvalST ICtx-evalCandsLoop cfg ictx0 ctx γ = go ictx0 0+evalCandsLoop :: Config -> ICtx -> Knowledge -> EvalST ICtx+evalCandsLoop cfg ictx0 γ = go ictx0 0   where-    go ictx _ | S.null (icCands ictx) = return ictx+    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 liftIO $ SMT.smtAssert ctx (pAndNoDedup (S.toList $ icAssms ictx))+        else do liftSMT $ SMT.smtAssertDecl $ pAndNoDedup $ S.toList $ icAssms ictx                 let ictx' = ictx { icAssms = mempty }-                    cands = S.toList $ icCands ictx-                candss <- mapM (evalOne γ ictx' i) cands-                us <- gets evNewEqualities-                modify $ \st -> st { evNewEqualities = mempty }-                let noCandidateChanged = and (zipWith eqCand candss cands)-                    unknownEqs = us `S.difference` icEquals ictx-                if S.null unknownEqs && noCandidateChanged-                      then return ictx-                      else do let eqsSMT = evalToSMT "evalCandsLoop" cfg ctx `S.map` unknownEqs-                              let ictx'' = ictx' { icEquals = icEquals ictx <> unknownEqs-                                                 , icAssms  = S.filter (not . isTautoPred) eqsSMT }-                              go (ictx'' { icCands = S.fromList (concat candss) }) (i + 1)+                    (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 =-      liftIO $ knPreds γ (knContext γ) (knLams γ) PFalse+      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 -> SInfo a+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 $ solver cfg) (atLoc dummySpan ("PLE1 " ++ show i)) env)) 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) @@ -363,13 +445,13 @@  data InstEnv a = InstEnv   { ieCfg   :: !Config-  , ieSMT   :: !SMT.Context   , ieBEnv  :: !(BindEnv a)   , ieAenv  :: !AxiomEnv   , ieCstrs :: !(CMap (SimpC a))   , ieKnowl :: !Knowledge   , ieEvEnv :: !EvalEnv   , ieLRWs  :: LocalRewritesEnv+  , ieSol :: Maybe Solution   }  ----------------------------------------------------------------------------------------------@@ -378,18 +460,22 @@  data ICtx    = ICtx   { icAssms              :: S.HashSet Pred           -- ^ Equalities converted to SMT format-  , icCands              :: S.HashSet Expr           -- ^ "Candidates" for unfolding-  , icEquals             :: EvEqualities             -- ^ Accumulated equalities+  , 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   }  ----------------------------------------------------------------------------------------------@@ -408,11 +494,13 @@ type CBranch = T.Branch SubcId type Diff    = [BindId]    -- ^ in "reverse" order -equalitiesPred :: [(Expr, Expr)] -> [Expr]-equalitiesPred eqs = [ EEq e1 e2 | (e1, e2) <- eqs, e1 /= e2 ]+equalitiesPred :: (Expr, Expr) -> Expr+equalitiesPred (e1, e2)+  | e1 /= e2 = EEq e1 e2+  | otherwise = PTrue -updCtxRes :: InstRes -> Maybe BindId -> [(Expr, Expr)] -> InstRes-updCtxRes res iMb = updRes res iMb . pAndNoDedup . equalitiesPred+updCtxRes :: InstRes -> Maybe BindId -> [Expr] -> InstRes+updCtxRes res iMb = updRes res iMb . pAndNoDedup   updRes :: InstRes -> Maybe BindId -> Expr -> InstRes@@ -422,41 +510,91 @@ ---------------------------------------------------------------------------------------------- -- | @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 :: InstEnv a -> ICtx -> Diff -> Maybe SubcId -> ICtx-updCtx InstEnv{..} ctx delta cidMb-            = ctx { icAssms  = S.fromList (filter (not . isTautoPred) ctxEqs)-                  , icCands  = S.fromList deANFedCands <> icCands  ctx-                  , icSimpl  = icSimpl ctx <> econsts-                  , icSubcId = cidMb-                  , icANFs   = anfBinds-                  , icLRWs   = mconcat $ icLRWs ctx : newLRWs-                  }+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 ctx+    anfBinds  = bs : icANFs ictx     econsts   = M.fromList $ findConstants ieKnowl es-    ctxEqs    = toSMT "updCtx" ieCfg ieSMT [] <$> L.nub-                  [ c | xr <- bs, c <- conjuncts (expr xr), null (Vis.kvarsExpr c) ]+    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     = [ (x, y) | i <- delta, let (x, y, _) = lookupBindEnv i ieBEnv]++    (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 -    deANFedCands =+    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 ctx-         || icEtaBetaFlag ctx then+         || 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@@ -481,8 +619,15 @@ data EvalEnv = EvalEnv   { evEnv      :: !SymEnv   , evElabF    :: ElabFlags-    -- | Equalities where we couldn't evaluate the guards-  , evPendingUnfoldings :: M.HashMap Expr Expr+  , 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@@ -508,6 +653,15 @@ 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]@@ -525,7 +679,7 @@ -- way. evalOne :: Knowledge -> ICtx -> Int -> Expr -> EvalST [Expr] evalOne γ ctx i e-  | i > 0 || null (getAutoRws γ (icSubcId ctx)) = (:[]) . fst <$> eval γ ctx NoRW 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@@ -555,37 +709,7 @@   | RWNormal   -- REST: Fully Expand Defs in the context of rewriting (similar to NoRW)   deriving (Eq) --- Indicates whether or not the evaluation has expanded a function statement--- into a conditional branch.--- In this case, rewriting should stop--- It's unclear whether or not rewriting in either branch makes sense,--- since one branch could be an ill-formed expression.-newtype FinalExpand = FE Bool deriving (Show) -noExpand :: FinalExpand-noExpand = FE False--expand :: FinalExpand-expand = FE True--mapFE :: (Expr -> Expr) -> (Expr, FinalExpand) -> (Expr, FinalExpand)-mapFE f (e, fe) = (f e, fe)--feVal :: FinalExpand -> Bool-feVal (FE f) = f--feAny :: [FinalExpand] -> FinalExpand-feAny xs = FE $ any feVal xs--infixl 9 <|>-(<|>) :: FinalExpand -> FinalExpand -> FinalExpand-(<|>) (FE True) _ = expand-(<|>) _         f = f---feSeq :: [(Expr, FinalExpand)] -> ([Expr], FinalExpand)-feSeq xs = (map fst xs, feAny (map snd xs))- -- | Unfolds function invocations in expressions. -- -- Also reduces if-then-else when the boolean condition or the negation can be@@ -594,70 +718,55 @@ -- -- Also adds to the monad state all the unfolding equalities that have been -- discovered as necessary.-eval :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST (Expr, FinalExpand)+eval :: 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)   = mapFE (ECoerc s t)  <$> go 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', finalExpand) <- feSeq <$> mapM (eval γ ctx et) es+            es' <- mapM (eval γ ctx et) es             if es /= es'-              then return (eApps f es', finalExpand)+              then return (eApps f es')               else do-                (f', fe) <- case dropECst f of-                  EVar _ -> pure (f, noExpand)+                f' <- case dropECst f of+                  EVar _ -> pure f                   _      -> go f-                (me', fe') <- evalApp γ ctx f' es et-                return (Mb.fromMaybe (eApps f' es') me', fe <|> fe')+                Mb.fromMaybe (eApps f' es') <$> evalApp γ ctx f' es et        (f, es) ->           do-            (f', fe1) <- case dropECst f of-              EVar _ -> pure (f, noExpand)+            f' <- case dropECst f of+              EVar _ -> pure f               _      -> go f-            (es', fe2) <- feSeq <$> mapM (eval γ ctx et) es-            let fe = fe1 <|> fe2-            (me', fe') <- evalApp γ ctx f' es' et-            return (Mb.fromMaybe (eApps f' es') me', fe <|> fe')+            es' <- mapM (eval γ ctx et) es+            Mb.fromMaybe (eApps f' es') <$> evalApp γ ctx f' es' et -    go (PAtom r e1 e2) = binOp (PAtom r) e1 e2-    go (ENeg e)         = do (e', fe)  <- go e-                             return (ENeg e', fe)-    go (EBin o e1 e2)   = do (e1', fe1) <- go e1-                             (e2', fe2) <- go e2-                             return (EBin o e1' e2', fe1 <|> fe2)-    go (ETApp e t)      = mapFE (`ETApp` t) <$> go e-    go (ETAbs e s)      = mapFE (`ETAbs` s) <$> go e-    go (PNot e')        = mapFE PNot <$> go e'-    go (PImp e1 e2)     = binOp PImp e1 e2-    go (PIff e1 e2)     = binOp PIff e1 e2-    go (PAnd es)        = efAll PAnd (go `traverse` es)-    go (POr es)         = efAll POr (go `traverse` es)+    go (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-      (me', fe) <- evalApp γ ctx e [] et-      return (Mb.fromMaybe e me', fe)-    go (ECst e t)       = do (e', fe) <- go e-                             return (ECst e' t, fe)-    go e                = return (e, noExpand)+      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 -    binOp f e1 e2 = do-      (e1', fe1) <- go e1-      (e2', fe2) <- go e2-      return (f e1' e2', fe1 <|> fe2)+    go e                = return e -    efAll f mes = do-      xs <- mes-      let (xs', fe) = feSeq xs-      return (f xs', fe) --- | 'evalELamb' produces equations that preserve the context of a rewrite+-- | '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, FinalExpand)+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@@ -686,7 +795,7 @@     modify $ \st -> st       { evEnv = insertSymEnv x s $ evEnv st } -    (e', fe) <- eval (γ { knLams = (x, s) : knLams γ }) ctx et e+    e' <- eval (γ { knLams = (x, s) : knLams γ }) ctx et e     let e2' = simplify γ ctx e'         elam = ELam (x, s) e     -- Discard the old equalities which miss the lambda binding@@ -696,7 +805,7 @@       -- Leaving the scope thus we need to get rid of it       , evEnv = deleteSymEnv x $ evEnv st       }-    return (ELam (x, s) e', fe)+    return (ELam (x, s) e')  data RESTParams oc = RP   { oc   :: OCAlgebra oc Expr IO@@ -795,21 +904,22 @@ evalRESTWithCache cacheRef γ ctx acc rp =   do     mexploredTerms <- gets explored+    ebs <- gets evExScope     case mexploredTerms of       Nothing -> return acc       Just exploredTerms -> do-        se <- liftIO (shouldExploreTerm exploredTerms exprs)+        se <- liftIO (shouldExploreTerm ebs exploredTerms exprs)         if se then do-          possibleRWs <- getRWs-          rws <- notVisitedFirst exploredTerms <$> filterM (liftIO . allowed) possibleRWs+          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', FE fe) <- do-            r@(ec, _) <- eval γ ctx FuncNormal exprs+          e' <- do+            ec <- eval γ ctx FuncNormal exprs             if ec /= exprs-              then return r+              then return ec               else eval γ ctx RWNormal exprs            let evalIsNewExpr = e' `L.notElem` pathExprs@@ -834,8 +944,8 @@             }            acc'' <- if evalIsNewExpr-            then if fe && any isRW (path rp)-              then (:[]) . fst <$> eval γ (addConst (exprs, e')) NoRW e'+            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' @@ -843,17 +953,17 @@         else           return acc   where-    shouldExploreTerm exploredTerms e | Vis.isConc e =-      case rwTerminationOpts rwArgs of+    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+    shouldExploreTerm _ _ _ = return False -    allowed (_, rwE, _) | rwE `elem` pathExprs = return False-    allowed (_, _, c)   = termCheck c-    termCheck c = Rewrite.passesTerminationCheck (oc rp) rwArgs c+    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@@ -879,21 +989,21 @@     exprs           = last pathExprs     autorws         = getAutoRws γ (icSubcId ctx) -    rwArgs = RWArgs (isValid cacheRef γ) $ knRWTerminationOpts γ+    rwArgs ebs = RWArgs (isValid cacheRef ebs γ) $ knRWTerminationOpts γ -    getRWs =+    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 (c rp)+            else liftIO $ termCheck ebs (c rp)         if ok           then             do-              let getRW e ar = Rewrite.getRewrite (oc rp) rwArgs (c rp) e ar-              let getRWs' s  = Mb.catMaybes <$> mapM (liftIO . runMaybeT . getRW s) autorws+              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 [] @@ -946,7 +1056,7 @@  -- | @evalApp kn ctx e es@ unfolds expressions in @eApps e es@ using rewrites -- and equations-evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Maybe Expr, FinalExpand)+evalApp :: Knowledge -> ICtx -> Expr -> [Expr] -> EvalType -> EvalST (Maybe Expr) evalApp γ ctx e0 es et   | EVar f <- dropECst e0   , Just eq <- Map.lookup f (knAms γ)@@ -962,7 +1072,7 @@                     then elaborateExpr "EvalApp unfold full: " newE                     else pure newE -         (e', fe) <- evalIte γ ctx et newE'        -- TODO:FUEL this is where an "unfolding" happens, CHECK/BUMP counter+         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 @@ -972,17 +1082,18 @@            -- If evalIte does any modifications, though, we do unfold in order            -- to allow analysis of the resulting expression            modify $ \st -> st-             { evPendingUnfoldings = M.insert (eApps e0 es) e3' (evPendingUnfoldings st)+             { evPendingUnfoldings =+                 M.insertWith M.union (evExScope st) (M.singleton (eApps e0 es) e3') (evPendingUnfoldings st)              }-           return (Nothing, noExpand)+           return Nothing          else do            useFuel f            modify $ \st -> st              { evNewEqualities = S.insert (eApps e0 es, e3') (evNewEqualities st)-             , evPendingUnfoldings = M.delete (eApps e0 es) (evPendingUnfoldings st)+             , evPendingUnfoldings = M.adjust (M.delete (eApps e0 es)) (evExScope st) (evPendingUnfoldings st)              }-           return (Just $ eApps e2' es2, fe)-       else return (Nothing, noExpand)+           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.@@ -1016,7 +1127,7 @@     when (isUserDataSMeasure == NoUserDataSMeasure) $       modify $ \st -> st         { evNewEqualities = S.insert (eApps e0 args, simplify γ ctx newE) (evNewEqualities st) }-    return (Just newE, noExpand)+    return (Just newE)  evalApp γ ctx e0 es _et   | eqs@(_:_) <- noUserDataMeasureEqs γ (eApps e0 es)@@ -1024,7 +1135,7 @@        let eqs' = map (second $ simplify γ ctx) eqs        modify $ \st ->          st { evNewEqualities = foldr S.insert (evNewEqualities st) eqs' }-       return (Nothing, noExpand)+       return Nothing  evalApp γ ctx e0 es et   | ELam (argName, _) body <- dropECst e0@@ -1037,13 +1148,13 @@           useFuel argName           let argSubst = mkSubst [(argName, lambdaArg)]           let body' = subst argSubst body-          (body'', fe) <- evalIte γ ctx et 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, fe)+          return (Just $ eApps body'' remArgs)         else do-          return (Nothing, noExpand)+          return Nothing  evalApp _ ctx e0 es _   | icLocalRewritesFlag ctx@@ -1054,7 +1165,7 @@       let expandedTerm = eApps rw es       modify $ \st -> st         { evNewEqualities = S.insert (eApps e0 es, expandedTerm) (evNewEqualities st) }-      return (Just expandedTerm, expand)+      return (Just expandedTerm)  evalApp _γ ctx e0 es _et   -- We check the annotation instead of the equations in γ for two reasons.@@ -1091,7 +1202,7 @@     -- is already handled by the previous case of evalApp     modify $ \st -> st       { evNewEqualities = S.insert (eApps e0 es, etaExpandedTerm) (evNewEqualities st) }-    return (Just etaExpandedTerm, expand)+    return (Just etaExpandedTerm)   where     unpackFFuncs (FFunc t ts) = t : unpackFFuncs ts     unpackFFuncs _ = []@@ -1099,22 +1210,21 @@     mkLams subject binds = foldr ELam subject binds  evalApp _ _ctx _e0 _es _ = do-  return (Nothing, noExpand)+  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, FinalExpand)+evalIte :: Knowledge -> ICtx -> EvalType -> Expr -> EvalST Expr evalIte γ ctx et (ECst e t) = do-  (e', fe) <- evalIte γ ctx et e-  return (ECst e' t, fe)+  (`ECst` t) <$> evalIte γ ctx et e evalIte γ ctx et (EIte i e1 e2) = do-      (b, _) <- eval γ ctx et i+      b <- eval γ ctx et i       b'  <- mytracepp ("evalEIt POS " ++ showpp (i, b)) <$> isValidCached γ b       case b' of         Just True -> evalIte γ ctx et e1         Just False -> evalIte γ ctx et e2-        _ -> return (EIte b e1 e2, expand)-evalIte _ _ _ e' = return (e', noExpand)+        _ -> 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@@ -1180,14 +1290,14 @@   case M.lookup e (evSMTCache env) of     Nothing -> do       let isFreeInE (s, _) = not (S.member s (exprSymbolsSet e))-      b <- liftIO $ knPreds γ (knContext γ) (knLams γ) 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 <- liftIO $ knPreds γ (knContext γ) (knLams γ) (PNot e)+          b2 <- knPredsEvalST γ (PNot e)           if b2             then do               when (all isFreeInE (knLams γ)) $@@ -1209,8 +1319,10 @@     -- user data declaration.     knSims              :: Map Symbol [(Rewrite, IsUserDataSMeasure)]   , knAms               :: Map Symbol Equation -- ^ All function definitions-  , knContext           :: SMT.Context-  , knPreds             :: SMT.Context -> [(Symbol, Sort)] -> Expr -> IO Bool+    -- | @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@@ -1226,25 +1338,29 @@ data IsUserDataSMeasure = NoUserDataSMeasure | UserDataSMeasure   deriving (Eq, Show) -isValid :: IORef (M.HashMap Expr Bool) -> Knowledge -> Expr -> IO Bool-isValid cacheRef γ e = do-    smtCache <- readIORef cacheRef+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 γ (knContext γ) (knLams γ) e+        b <- knPreds γ bs (knLams γ) e         when b $-          writeIORef cacheRef (M.insert e True smtCache)+          liftIO $ writeIORef cacheRef (M.insert e True smtCache)         return b-      mb -> return (mb == Just True)+      Just b -> return b -knowledge :: Config -> SMT.Context -> SInfo a -> Knowledge-knowledge cfg ctx si = KN+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]-  , knContext                  = ctx-  , knPreds                    = askSMT  cfg+  , knPreds                    = askSMT cfg   , knLams                     = []   , knSummary                  =    ((\s -> (smName s, 1)) <$> sims)                                  ++ ((\s -> (eqName s, length (eqArgs s))) <$> aenvEqs aenv)@@ -1255,7 +1371,7 @@   , knConsts                   = Mb.mapMaybe makeCons sims   , knAutoRWs                  = aenvAutoRW aenv   , knRWTerminationOpts        =-      if rwTerminationCheck cfg+      if rwTermination cfg       then RWTerminationCheckEnabled       else RWTerminationCheckDisabled   }@@ -1335,15 +1451,6 @@ -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -withCtx :: Config -> FilePath -> SymEnv -> [Equation] -> (SMT.Context -> IO a) -> IO a-withCtx cfg file env defns k = do-  ctx <- SMT.makeContextWithSEnv cfg file env defns-  _   <- 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))]@@ -1466,7 +1573,8 @@ elaborateExpr :: String -> Expr -> EvalST Expr elaborateExpr msg e = do   let elabSpan = atLoc dummySpan msg-  symEnv' <- gets evEnv+  env <- get+  let symEnv' = insertsSymEnv (evEnv env) (evExScope env)   ef <- gets evElabF   pure $ unApply $ elaborate (ElabParam ef elabSpan symEnv') e @@ -1478,3 +1586,128 @@   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) ]

@@ -30,6 +30,7 @@ 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)@@ -54,7 +55,7 @@   | RWTerminationCheckDisabled  data RewriteArgs = RWArgs- { isRWValid          :: Expr -> IO Bool+ { isRWValid          :: Expr -> SmtM Bool  , rwTerminationOpts  :: RWTerminationOpts  } @@ -128,7 +129,7 @@   -> oc   -> SubExpr   -> AutoRewrite-  -> MaybeT IO ((Expr, Expr), Expr, oc)+  -> MaybeT SmtM ((Expr, Expr), Expr, oc) getRewrite aoc rwArgs c (subE, toE) (AutoRewrite args lhs rhs) =   do     su <- MaybeT $ return $ unify freeVars lhs subE@@ -145,7 +146,7 @@           (eqn, expr', c')       RWTerminationCheckDisabled -> (eqn, expr', c)   where-    check :: Expr -> MaybeT IO ()+    check :: Expr -> MaybeT SmtM ()     check e = do       valid <- MaybeT $ Just <$> isRWValid rwArgs e       guard valid@@ -225,6 +226,15 @@  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'+ subExprs' _ = []  -- | Computes the subexpressions of a list of expressions.@@ -304,8 +314,8 @@       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+    (ELet _ rw1 rw2, ELet _ seen1 seen2) ->+      unifyAll freeVars [rw1, rw2] [seen1, seen2]     _ -> Nothing